~ chicken-core (chicken-5) f88c56121555f66c6892808c7b946b2f73fe126a
commit f88c56121555f66c6892808c7b946b2f73fe126a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Dec 18 11:16:50 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Dec 18 11:16:50 2009 +0100
added fpinteger?; unboxing fixes; renamed unboxing types; removed rewrite-parameters related to obsolete rest-arg-as-vector optimization
diff --git a/NEWS b/NEWS
index aabd1d0a..415b2b23 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,8 @@
+4.2.15
+
+- added `fpinteger?'
+- added unboxing pass to compiler
+
4.2.14
- `move-memory!' catches negative offsets now (Thanks to Jim Ursetto)
diff --git a/c-backend.scm b/c-backend.scm
index a1cad4dd..c851520e 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -725,10 +725,11 @@
(define (utype t)
(case t
- ((fix) "int")
- ((flo) "double")
- ((chr) "char")
- ((ptr) "void *")
+ ((fixnum) "int")
+ ((flonum) "double")
+ ((char) "char")
+ ((pointer) "void *")
+ ((bool) "int")
(else (bomb "invalid unboxed type" t))))
(define (procedures)
diff --git a/c-platform.scm b/c-platform.scm
index fb4e2c5b..19781b8e 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -128,7 +128,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?
fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos fpatan
- fpatan2 fpexp fpexpt fplog fpsqrt fpabs
+ fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger?
arithmetic-shift void flush-output thread-specific thread-specific-set!
not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
@@ -506,133 +506,134 @@
(rewrite 'locative-ref 13 "C_locative_ref" #t)
(rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t)
-(rewrite 'caar 2 1 "C_u_i_caar" #f #f)
-(rewrite 'cdar 2 1 "C_u_i_cdar" #f #f)
-(rewrite 'cddr 2 1 "C_u_i_cddr" #f #f)
-(rewrite 'caaar 2 1 "C_u_i_caaar" #f #f)
-(rewrite 'cadar 2 1 "C_u_i_cadar" #f #f)
-(rewrite 'caddr 2 1 "C_u_i_caddr" #f #f)
-(rewrite 'cdaar 2 1 "C_u_i_cdaar" #f #f)
-(rewrite 'cdadr 2 1 "C_u_i_cdadr" #f #f)
-(rewrite 'cddar 2 1 "C_u_i_cddar" #f #f)
-(rewrite 'cdddr 2 1 "C_u_i_cdddr" #f #f)
-(rewrite 'caaaar 2 1 "C_u_i_caaaar" #f #f)
-(rewrite 'caadar 2 1 "C_u_i_caadar" #f #f)
-(rewrite 'caaddr 2 1 "C_u_i_caaddr" #f #f)
-(rewrite 'cadaar 2 1 "C_u_i_cadaar" #f #f)
-(rewrite 'cadadr 2 1 "C_u_i_cadadr" #f #f)
-(rewrite 'caddar 2 1 "C_u_i_caddar" #f #f)
-(rewrite 'cadddr 2 1 "C_u_i_cadddr" #f #f)
-(rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f #f)
-(rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f #f)
-(rewrite 'cdadar 2 1 "C_u_i_cdadar" #f #f)
-(rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f #f)
-(rewrite 'cddaar 2 1 "C_u_i_cddaar" #f #f)
-(rewrite 'cddadr 2 1 "C_u_i_cddadr" #f #f)
-(rewrite 'cdddar 2 1 "C_u_i_cdddar" #f #f)
-(rewrite 'cddddr 2 1 "C_u_i_cddddr" #f #f)
-
-(rewrite 'cddr 2 1 "C_i_cddr" #t #f)
-(rewrite 'cdddr 2 1 "C_i_cdddr" #t #f)
-(rewrite 'cddddr 2 1 "C_i_cddddr" #t #f)
+(rewrite 'caar 2 1 "C_u_i_caar" #f)
+(rewrite 'cdar 2 1 "C_u_i_cdar" #f)
+(rewrite 'cddr 2 1 "C_u_i_cddr" #f)
+(rewrite 'caaar 2 1 "C_u_i_caaar" #f)
+(rewrite 'cadar 2 1 "C_u_i_cadar" #f)
+(rewrite 'caddr 2 1 "C_u_i_caddr" #f)
+(rewrite 'cdaar 2 1 "C_u_i_cdaar" #f)
+(rewrite 'cdadr 2 1 "C_u_i_cdadr" #f)
+(rewrite 'cddar 2 1 "C_u_i_cddar" #f)
+(rewrite 'cdddr 2 1 "C_u_i_cdddr" #f)
+(rewrite 'caaaar 2 1 "C_u_i_caaaar" #f)
+(rewrite 'caadar 2 1 "C_u_i_caadar" #f)
+(rewrite 'caaddr 2 1 "C_u_i_caaddr" #f)
+(rewrite 'cadaar 2 1 "C_u_i_cadaar" #f)
+(rewrite 'cadadr 2 1 "C_u_i_cadadr" #f)
+(rewrite 'caddar 2 1 "C_u_i_caddar" #f)
+(rewrite 'cadddr 2 1 "C_u_i_cadddr" #f)
+(rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f)
+(rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f)
+(rewrite 'cdadar 2 1 "C_u_i_cdadar" #f)
+(rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f)
+(rewrite 'cddaar 2 1 "C_u_i_cddaar" #f)
+(rewrite 'cddadr 2 1 "C_u_i_cddadr" #f)
+(rewrite 'cdddar 2 1 "C_u_i_cdddar" #f)
+(rewrite 'cddddr 2 1 "C_u_i_cddddr" #f)
+
+(rewrite 'cddr 2 1 "C_i_cddr" #t)
+(rewrite 'cdddr 2 1 "C_i_cdddr" #t)
+(rewrite 'cddddr 2 1 "C_i_cddddr" #t)
(rewrite 'cdr 7 1 "C_slot" 1 #f)
-(rewrite 'cdr 2 1 "C_i_cdr" #t #f)
+(rewrite 'cdr 2 1 "C_i_cdr" #t)
(rewrite 'eq? 1 2 "C_eqp")
(rewrite '##sys#eq? 1 2 "C_eqp")
(rewrite 'eqv? 1 2 "C_i_eqvp")
(rewrite '##sys#eqv? 1 2 "C_i_eqvp")
-(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot")
-(rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref")
-(rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp")
-(rewrite '##sys#null? 2 1 "C_i_nullp" #t "C_vemptyp")
-(rewrite 'length 2 1 "C_i_length" #t "C_block_size")
-(rewrite 'not 2 1 "C_i_not" #t #f)
-(rewrite 'char? 2 1 "C_charp" #t #f)
-(rewrite 'string? 2 1 "C_i_stringp" #t #f)
-(rewrite 'locative? 2 1 "C_i_locativep" #t #f)
-(rewrite 'symbol? 2 1 "C_i_symbolp" #t #f)
-(rewrite 'vector? 2 1 "C_i_vectorp" #t #f)
-(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t #f)
-(rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
-(rewrite '##sys#pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
-(rewrite 'procedure? 2 1 "C_i_closurep" #t #f)
-(rewrite 'port? 2 1 "C_i_portp" #t #f)
-(rewrite 'boolean? 2 1 "C_booleanp" #t #f)
-(rewrite 'number? 2 1 "C_i_numberp" #t #f)
-(rewrite 'complex? 2 1 "C_i_numberp" #t #f)
-(rewrite 'rational? 2 1 "C_i_rationalp" #t #f)
-(rewrite 'real? 2 1 "C_i_numberp" #t #f)
-(rewrite 'integer? 2 1 "C_i_integerp" #t #f)
-(rewrite 'flonum? 2 1 "C_i_flonump" #t #f)
-(rewrite 'fixnum? 2 1 "C_fixnump" #t #f)
-(rewrite 'finite? 2 1 "C_i_finitep" #f #f)
-(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t #f)
-(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f)
-(rewrite 'exact? 2 1 "C_fixnump" #f #f)
-(rewrite 'exact? 2 1 "C_i_exactp" #t #f)
-(rewrite 'exact? 2 1 "C_u_i_exactp" #f #f)
-(rewrite 'inexact? 2 1 "C_nfixnump" #f #f)
-(rewrite 'inexact? 2 1 "C_i_inexactp" #t #f)
-(rewrite 'inexact? 2 1 "C_u_i_inexactp" #f #f)
-(rewrite 'list? 2 1 "C_i_listp" #t #f)
-(rewrite 'proper-list? 2 1 "C_i_listp" #t #f)
-(rewrite 'eof-object? 2 1 "C_eofp" #t #f)
-(rewrite 'string-ref 2 2 "C_subchar" #f #f)
-(rewrite 'string-ref 2 2 "C_i_string_ref" #t #f)
-(rewrite 'string-set! 2 3 "C_setsubchar" #f #f)
-(rewrite 'string-set! 2 3 "C_i_string_set" #t #f)
-(rewrite 'vector-ref 2 2 "C_slot" #f #f)
-(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t #f)
-(rewrite 'char=? 2 2 "C_eqp" #t #f)
-(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t #f)
-(rewrite 'char<? 2 2 "C_fixnum_lessp" #t #f)
-(rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t #f)
-(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f)
-(rewrite '##sys#slot 2 2 "C_slot" #t #f) ; consider as safe, the primitive is unsafe anyway.
-(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ;*** must be safe for pattern matcher (anymore?)
-(rewrite '##sys#size 2 1 "C_block_size" #t #f)
-(rewrite 'fxnot 2 1 "C_fixnum_not" #t #f)
-(rewrite 'fx* 2 2 "C_fixnum_times" #t #f)
-(rewrite 'fx/ 2 2 "C_fixnum_divide" #f #f)
-(rewrite 'fxmod 2 2 "C_fixnum_modulo" #f #f)
-(rewrite 'fx= 2 2 "C_eqp" #t #f)
-(rewrite 'fx> 2 2 "C_fixnum_greaterp" #t #f)
-(rewrite 'fx< 2 2 "C_fixnum_lessp" #t #f)
-(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t #f)
-(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t #f)
-(rewrite 'fp= 2 2 "C_flonum_equalp" #t #f)
-(rewrite 'fp> 2 2 "C_flonum_greaterp" #t #f)
-(rewrite 'fp< 2 2 "C_flonum_lessp" #t #f)
-(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t #f)
-(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t #f)
-(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t #f)
-(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t #f)
-(rewrite 'fpmax 2 2 "C_i_flonum_max" #t #f)
-(rewrite 'fpmin 2 2 "C_i_flonum_min" #t #f)
-(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t #f)
-(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t #f)
-(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t #f)
-(rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t #f)
-(rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t #f)
-(rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t #f)
-(rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t #f)
-(rewrite 'list-tail 2 2 "C_i_list_tail" #t #f)
-(rewrite '##sys#structure? 2 2 "C_i_structurep" #t #f)
-(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t #f)
-(rewrite 'block-ref 2 2 "C_slot" #f #f) ; ok to be unsafe, lolevel is anyway
-(rewrite 'number-of-slots 2 1 "C_block_size" #f #f)
+(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f)
+(rewrite 'list-ref 2 2 "C_i_list_ref" #t)
+(rewrite 'null? 2 1 "C_i_nullp" #t)
+(rewrite '##sys#null? 2 1 "C_i_nullp" #t)
+(rewrite 'length 2 1 "C_i_length" #t)
+(rewrite 'not 2 1 "C_i_not"#t )
+(rewrite 'char? 2 1 "C_charp" #t)
+(rewrite 'string? 2 1 "C_i_stringp" #t)
+(rewrite 'locative? 2 1 "C_i_locativep" #t)
+(rewrite 'symbol? 2 1 "C_i_symbolp" #t)
+(rewrite 'vector? 2 1 "C_i_vectorp" #t)
+(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t)
+(rewrite 'pair? 2 1 "C_i_pairp" #t)
+(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)
+(rewrite 'procedure? 2 1 "C_i_closurep" #t)
+(rewrite 'port? 2 1 "C_i_portp" #t)
+(rewrite 'boolean? 2 1 "C_booleanp" #t)
+(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 'integer? 2 1 "C_i_integerp" #t)
+(rewrite 'flonum? 2 1 "C_i_flonump" #t)
+(rewrite 'fixnum? 2 1 "C_fixnump" #t)
+(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 '##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)
+(rewrite 'proper-list? 2 1 "C_i_listp" #t)
+(rewrite 'eof-object? 2 1 "C_eofp" #t)
+(rewrite 'string-ref 2 2 "C_subchar" #f)
+(rewrite 'string-ref 2 2 "C_i_string_ref" #t)
+(rewrite 'string-set! 2 3 "C_setsubchar" #f)
+(rewrite 'string-set! 2 3 "C_i_string_set" #t)
+(rewrite 'vector-ref 2 2 "C_slot" #f)
+(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t)
+(rewrite 'char=? 2 2 "C_eqp" #t)
+(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t)
+(rewrite 'char<? 2 2 "C_fixnum_lessp" #t)
+(rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t)
+(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t)
+(rewrite '##sys#slot 2 2 "C_slot" #t) ; consider as safe, the primitive is unsafe anyway.
+(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t) ;*** must be safe for pattern matcher (anymore?)
+(rewrite '##sys#size 2 1 "C_block_size" #t)
+(rewrite 'fxnot 2 1 "C_fixnum_not" #t)
+(rewrite 'fx* 2 2 "C_fixnum_times" #t)
+(rewrite 'fx/ 2 2 "C_fixnum_divide" #f)
+(rewrite 'fxmod 2 2 "C_fixnum_modulo" #f)
+(rewrite 'fx= 2 2 "C_eqp" #t)
+(rewrite 'fx> 2 2 "C_fixnum_greaterp" #t)
+(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 '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)
+(rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t)
+(rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t)
+(rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t)
+(rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t)
+(rewrite 'list-tail 2 2 "C_i_list_tail" #t)
+(rewrite '##sys#structure? 2 2 "C_i_structurep" #t)
+(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t)
+(rewrite 'block-ref 2 2 "C_slot" #f) ; ok to be unsafe, lolevel is anyway
+(rewrite 'number-of-slots 2 1 "C_block_size" #f)
(rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")
-(rewrite 'assv 2 2 "C_i_assv" #t #f)
+(rewrite 'assv 2 2 "C_i_assv" #t)
(rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")
-(rewrite 'memv 2 2 "C_i_memv" #t #f)
+(rewrite 'memv 2 2 "C_i_memv" #t)
(rewrite 'assq 17 2 "C_i_assq" "C_u_i_assq")
(rewrite 'memq 17 2 "C_i_memq" "C_u_i_memq")
-(rewrite 'assoc 2 2 "C_i_assoc" #t #f)
-(rewrite 'member 2 2 "C_i_member" #t #f)
+(rewrite 'assoc 2 2 "C_i_assoc" #t)
+(rewrite 'member 2 2 "C_i_member" #t)
(rewrite 'set-car! 4 '##sys#setslot 0)
(rewrite 'set-cdr! 4 '##sys#setslot 1)
@@ -666,47 +667,47 @@
(rewrite 'atan 16 2 "C_a_i_atan2" #t words-per-flonum)
(rewrite 'zero? 5 "C_eqp" 0 'fixnum)
-(rewrite 'zero? 2 1 "C_i_zerop" #t #f)
-(rewrite 'zero? 2 1 "C_u_i_zerop" #f #f)
+(rewrite 'zero? 2 1 "C_i_zerop" #t)
+(rewrite 'zero? 2 1 "C_u_i_zerop" #f)
(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum)
(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum)
-(rewrite 'positive? 2 1 "C_i_positivep" #t #f)
-(rewrite 'positive? 2 1 "C_u_i_positivep" #f #f)
+(rewrite 'positive? 2 1 "C_i_positivep" #t)
+(rewrite 'positive? 2 1 "C_u_i_positivep" #f)
(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum)
(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum)
-(rewrite 'negative? 2 1 "C_i_negativep" #t #f)
-(rewrite 'negative? 2 1 "C_u_i_negativep" #f #f)
+(rewrite 'negative? 2 1 "C_i_negativep" #t)
+(rewrite 'negative? 2 1 "C_u_i_negativep" #f)
(rewrite 'vector-length 6 "C_fix" "C_header_size" #f)
(rewrite 'string-length 6 "C_fix" "C_header_size" #f)
(rewrite 'char->integer 6 "C_fix" "C_character_code" #t)
(rewrite 'integer->char 6 "C_make_character" "C_unfix" #t)
-(rewrite 'vector-length 2 1 "C_i_vector_length" #t #f)
-(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t #f)
-(rewrite 'string-length 2 1 "C_i_string_length" #t #f)
-(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f)
-
-(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t #f)
-(rewrite '##sys#check-number 2 1 "C_i_check_number" #t #f)
-(rewrite '##sys#check-list 2 1 "C_i_check_list" #t #f)
-(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t #f)
-(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t #f)
-(rewrite '##sys#check-string 2 1 "C_i_check_string" #t #f)
-(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t #f)
-(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t #f)
-(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t #f)
-(rewrite '##sys#check-char 2 1 "C_i_check_char" #t #f)
-(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t #f)
-(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t #f)
-(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t #f)
-(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t #f)
-(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t #f)
-(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t #f)
-(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t #f)
-(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t #f)
-(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t #f)
-(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t #f)
+(rewrite 'vector-length 2 1 "C_i_vector_length" #t)
+(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t)
+(rewrite 'string-length 2 1 "C_i_string_length" #t)
+(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t)
+
+(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t)
+(rewrite '##sys#check-number 2 1 "C_i_check_number" #t)
+(rewrite '##sys#check-list 2 1 "C_i_check_list" #t)
+(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t)
+(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t)
+(rewrite '##sys#check-string 2 1 "C_i_check_string" #t)
+(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t)
+(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t)
+(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t)
+(rewrite '##sys#check-char 2 1 "C_i_check_char" #t)
+(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t)
+(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t)
+(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t)
+(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t)
+(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t)
+(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t)
+(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t)
+(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t)
+(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t)
+(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t)
(rewrite '= 9 "C_eqp" "C_i_equalp" #t #t)
(rewrite '> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f)
@@ -726,7 +727,7 @@
(rewrite 'list->string 11 1 '##sys#list->string #t)
(rewrite 'vector-set! 11 3 '##sys#setslot #f)
-(rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f)
+(rewrite 'vector-set! 2 3 "C_i_vector_set" #t)
(rewrite '##sys#vector->list 11 1 'vector->list #t)
(rewrite '##sys#list->vector 11 1 'list->vector #t)
@@ -778,10 +779,10 @@
(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")
-(rewrite 'even? 2 1 "C_i_evenp" #t #f)
-(rewrite 'even? 2 1 "C_u_i_evenp" #f #f)
-(rewrite 'odd? 2 1 "C_i_oddp" #t #f)
-(rewrite 'odd? 2 1 "C_u_i_oddp" #f #f)
+(rewrite 'even? 2 1 "C_i_evenp" #t)
+(rewrite 'even? 2 1 "C_u_i_evenp" #f)
+(rewrite 'odd? 2 1 "C_i_oddp" #t)
+(rewrite 'odd? 2 1 "C_u_i_oddp" #f)
(rewrite 'floor 15 'flonum 'fixnum 'fpfloor #f)
(rewrite 'ceiling 15 'flonum 'fixnum 'fpceiling #f)
@@ -901,12 +902,12 @@
(rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp")
(rewrite '##sys#direct-return 17 2 "C_direct_return")
-(rewrite 'blob-size 2 1 "C_block_size" #f #f)
+(rewrite 'blob-size 2 1 "C_block_size" #f)
-(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f)
-(rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f #f)
-(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f)
-(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f)
+(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f)
+(rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f)
+(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f)
+(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f)
(rewrite 'f32vector-ref 16 2 "C_a_i_f32vector_ref" #f words-per-flonum)
(rewrite 'f64vector-ref 16 2 "C_a_i_f64vector_ref" #f words-per-flonum)
@@ -914,23 +915,23 @@
(rewrite 'u32vector-ref 22 2 "C_a_i_u32vector_ref" #f words-per-flonum "C_u_i_u32vector_ref")
(rewrite 's32vector-ref 22 2 "C_a_i_s32vector_ref" #f words-per-flonum "C_u_i_s32vector_ref")
-(rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f #f)
-(rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f #f)
-(rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f #f)
-(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f)
-(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f)
-(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f)
-(rewrite 'f32vector-set! 2 3 "C_u_i_f32vector_set" #f #f)
-(rewrite 'f64vector-set! 2 3 "C_u_i_f64vector_set" #f #f)
-
-(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f)
-(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f)
-(rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f #f)
-(rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f #f)
-(rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f #f)
-(rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f #f)
-(rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f #f)
-(rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f #f)
+(rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f)
+(rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f)
+(rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f)
+(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f)
+(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f)
+(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f)
+(rewrite 'f32vector-set! 2 3 "C_u_i_f32vector_set" #f)
+(rewrite 'f64vector-set! 2 3 "C_u_i_f64vector_set" #f)
+
+(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f)
+(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f)
+(rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f)
+(rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f)
+(rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f)
+(rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f)
+(rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f)
+(rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f)
(rewrite 'not-pair? 17 1 "C_i_not_pair_p")
(rewrite 'atom? 17 1 "C_i_not_pair_p")
diff --git a/chicken.h b/chicken.h
index b6506e1c..d8941748 100644
--- a/chicken.h
+++ b/chicken.h
@@ -887,6 +887,7 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_round round
# define C_trunc trunc
# define C_fabs fabs
+# define C_modf modf
# ifdef __linux__
extern double round(double);
extern double trunc(double);
@@ -1766,7 +1767,7 @@ C_inline C_word C_double_to_number(C_word n)
double m, f = C_flonum_magnitude(n);
if(f <= (double)C_MOST_POSITIVE_FIXNUM
- && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
+ && f >= (double)C_MOST_NEGATIVE_FIXNUM && C_modf(f, &m) == 0.0)
return C_fix(f);
else return n;
}
@@ -1779,7 +1780,7 @@ C_inline C_word C_fits_in_int_p(C_word x)
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
n = C_flonum_magnitude(x);
- return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
+ return C_mk_bool(C_modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
}
@@ -1790,7 +1791,7 @@ C_inline C_word C_fits_in_unsigned_int_p(C_word x)
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
n = C_flonum_magnitude(x);
- return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
+ return C_mk_bool(C_modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
}
@@ -1993,13 +1994,21 @@ C_inline C_word C_i_rationalp(C_word x)
}
+C_inline C_word C_u_i_fpintegerp(C_word x)
+{
+ double dummy;
+
+ return C_mk_bool(C_modf(C_flonum_magnitude(x), &dummy) == 0.0);
+}
+
+
C_inline C_word C_i_integerp(C_word x)
{
double dummy;
return C_mk_bool((x & C_FIXNUM_BIT) ||
((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
- modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
+ C_modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
}
diff --git a/library.scm b/library.scm
index fe6da61f..3742fc9b 100644
--- a/library.scm
+++ b/library.scm
@@ -1,7 +1,7 @@
;;;; library.scm - R5RS library for the CHICKEN compiler
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -967,6 +967,11 @@ EOF
(fp-check-flonum x 'fpabs)
(##core#inline_allocate ("C_a_i_flonum_abs" 4) x))
+(define (fpinteger? x)
+ #+(not unsafe)
+ (fp-check-flonum x 'fpinteger?)
+ (##core#inline "C_u_i_fpintegerp" x))
+
(define * (##core#primitive "C_times"))
(define - (##core#primitive "C_minus"))
(define + (##core#primitive "C_plus"))
diff --git a/manual/Unit library b/manual/Unit library
index 89d16720..9c4705b5 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -89,11 +89,11 @@ Returns {{#t}} if {{X}} is a fixnum, or {{#f}} otherwise.
==== Arithmetic floating-point operations
-arguments (except {{flonum?}}, which returns {{#f}}). In unsafe mode,
-these procedures do not check their arguments. A non-flonum argument
-in unsafe mode can crash the system.
+In safe mode, these procedures throw a type error when given non-float
+arguments. In unsafe mode, these procedures do not check their
+arguments. A non-flonum argument in unsafe mode can crash the
+application.
-<procedure>(flonum? X)</procedure>
<procedure>(fp+ X Y)</procedure>
<procedure>(fp- X Y)</procedure>
<procedure>(fp* X Y)</procedure>
@@ -122,6 +122,7 @@ in unsafe mode can crash the system.
<procedure>(fpexpt X Y)</procedure>
<procedure>(fpsqrt X)</procedure>
<procedure>(fpabs X)</procedure>
+<procedure>(fpinteger? X)</procedure>
Note: {{fpround}} implements POSIX, which is different from R5RS.
diff --git a/optimizer.scm b/optimizer.scm
index edcc685f..415e7009 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -812,23 +812,17 @@
(list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
;; (<op> ...) -> (##core#inline <iop> ...)
- ;; (<op> <rest-vector>) -> (##core#inline <iopv> <rest-vector>)
- ((2) ; classargs = (<argc> <iop> <safe> <iopv>)
+ ((2) ; classargs = (<argc> <iop> <safe>)
(and inline-substitutions-enabled
(= (length callargs) (first classargs))
(intrinsic? name)
(or (third classargs) unsafe)
- (let ([arg1 (first callargs)]
- [iopv (fourth classargs)] )
+ (let ((arg1 (first callargs)))
(make-node
'##core#call '(#t)
(list
cont
- (cond [(and iopv
- (eq? '##core#variable (node-class arg1))
- (eq? 'vector (get db (first (node-parameters arg1)) 'rest-parameter)) )
- (make-node '##core#inline (list iopv) callargs) ]
- [else (make-node '##core#inline (list (second classargs)) callargs)] ) ) ) ) ) )
+ (make-node '##core#inline (list (second classargs)) callargs) ) ) ) ) )
;; (<op>) -> <var>
((3) ; classargs = (<var>)
diff --git a/types.db b/types.db
index aad41ea8..39a0fa5e 100644
--- a/types.db
+++ b/types.db
@@ -307,7 +307,8 @@
(fpcos (procedure fpcos (float) float))
(fpexp (procedure fpexp (float) float))
(fpexpt (procedure fpexpt (float float) float))
-(fpfloot (procedure fpfloor (float) float))
+(fpfloor (procedure fpfloor (float) float))
+(fpinteger? (procedure fpinteger? (float) boolean))
(fplog (procedure fplog (float) float))
(fpmax (procedure fpmax (float float) float))
(fpmin (procedure fpmin (float float) float))
diff --git a/unboxing.scm b/unboxing.scm
index 86ec0093..e6975c4e 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -111,21 +111,25 @@
(list
n2
(case rtype
- ((flo)
+ ((flonum)
(make-node
'##core#inline_allocate (list "C_a_i_flonum" 4) ; hardcoded size
(list (make-node '##core#unboxed_ref (list tmp rtype) '()))))
- ((ptr)
+ ((pointer)
(make-node
'##core#inline_allocate (list "C_a_i_mpointer" 2) ; hardcoded size
(list (make-node '##core#unboxed_ref (list tmp rtype) '()))))
- ((chr fix)
+ ((char fixnum)
(make-node
'##core#inline
- (list (if (eq? rtype 'chr) "C_make_character" "C_fix"))
+ (list (if (eq? rtype 'char) "C_make_character" "C_fix"))
(list (make-node
'##core#unboxed_ref
(list tmp rtype) '()))))
+ ((bool)
+ (make-node
+ '##core#inline '("C_mk_bool")
+ (list (make-node '##core#unboxed_ref (list tmp rtype) '()))))
((*) (bomb "unboxed type `*' not allowed as result"))
(else (bomb "invalid unboxed type" rtype)))))))))
((or (eq? (car atypes) '*)
@@ -142,12 +146,13 @@
(list (make-node
'##core#inline
(list (case (car atypes)
- ((chr) "C_character_code")
- ((fix) "C_unfix")
- ((flo) "C_flonum_magnitude")
- ((ptr) "C_pointer_address")
+ ((char) "C_character_code")
+ ((fixnum) "C_unfix")
+ ((flonum) "C_flonum_magnitude")
+ ((pointer) "C_pointer_address")
+ ((bool) "C_truep")
((*) "C_id")
- (else (bomb "invalid unboxed type" (car atypes)))))
+ (else (bomb "invalid unboxed argument type" (car atypes)))))
(list (car anodes)))
(loop (cdr args)
(cdr anodes)
@@ -327,7 +332,7 @@
(if (eq? r 'none)
(walk (second clauses) dest udest pass2?)
(merge r (walk (second clauses) dest udest pass2?)))))
- ((null? (cddr clauses))
+ ((null? (cdr clauses))
(merge r (walk (car clauses) dest udest pass2?))) ) )
((##core#call ##core#direct_call)
@@ -371,28 +376,31 @@
;; unboxed rewrites
(define-unboxed-ops
- (C_a_i_flonum_plus (flo flo) flo "C_ub_i_flonum_plus")
- (C_a_i_flonum_difference (flo flo) flo "C_ub_i_flonum_difference")
- (C_a_i_flonum_times (flo flo) flo "C_ub_i_flonum_times")
- (C_a_i_flonum_quotient (flo flo) flo "C_ub_i_flonum_quotient")
- (C_a_i_flonum_sin (flo) flo "C_sin")
- (C_a_i_flonum_cos (flo) flo "C_cos")
- (C_a_i_flonum_tan (flo) flo "C_tab")
- (C_a_i_flonum_asin (flo) flo "C_asin")
- (C_a_i_flonum_acos (flo) flo "C_acos")
- (C_a_i_flonum_atan (flo) flo "C_atan")
- (C_a_i_flonum_atan2 (flo flo) flo "C_atan2")
- (C_a_i_flonum_exp (flo) flo "C_exp")
- (C_a_i_flonum_expt (flo flo) flo "C_pow")
- (C_a_i_flonum_log (flo) flo "C_log")
- (C_a_i_flonum_sqrt (flo) flo "C_sqrt")
- (C_a_i_flonum_abs (flo) flo "C_fabs")
- (C_a_i_flonum_truncate (flo) flo "C_trunc")
- (C_a_i_flonum_ceiling (flo) flo "C_ceil")
- (C_a_i_flonum_floor (flo) flo "C_floor")
- (C_a_i_flonum_round (flo) flo "C_round")
- (C_u_i_f32vector_set (* fix flo) fix "C_ub_i_f32vector_set")
- (C_u_i_f64vector_set (* fix flo) fix "C_ub_i_f64vector_set")
- (C_a_i_f32vector_ref (* fix) flo "C_ub_i_f32vector_ref")
- (C_a_i_f64vector_ref (* fix) flo "C_ub_i_f64vector_ref")
+ (C_a_i_flonum_plus (flonum flonum) flonum "C_ub_i_flonum_plus")
+ (C_a_i_flonum_difference (flonum flonum) flonum "C_ub_i_flonum_difference")
+ (C_a_i_flonum_times (flonum flonum) flonum "C_ub_i_flonum_times")
+ (C_a_i_flonum_quotient (flonum flonum) flonum "C_ub_i_flonum_quotient")
+ (C_a_i_flonum_sin (flonum) flonum "C_sin")
+ (C_a_i_flonum_cos (flonum) flonum "C_cos")
+ (C_a_i_flonum_tan (flonum) flonum "C_tab")
+ (C_a_i_flonum_asin (flonum) flonum "C_asin")
+ (C_a_i_flonum_acos (flonum) flonum "C_acos")
+ (C_a_i_flonum_atan (flonum) flonum "C_atan")
+ (C_a_i_flonum_atan2 (flonum flonum) flonum "C_atan2")
+ (C_a_i_flonum_exp (flonum) flonum "C_exp")
+ (C_a_i_flonum_expt (flonum flonum) flonum "C_pow")
+ (C_a_i_flonum_log (flonum) flonum "C_log")
+ (C_a_i_flonum_sqrt (flonum) flonum "C_sqrt")
+ (C_a_i_flonum_abs (flonum) flonum "C_fabs")
+ (C_a_i_flonum_truncate (flonum) flonum "C_trunc")
+ (C_a_i_flonum_ceiling (flonum) flonum "C_ceil")
+ (C_a_i_flonum_floor (flonum) flonum "C_floor")
+ (C_a_i_flonum_round (flonum) flonum "C_round")
+ (C_u_i_f32vector_set (* fixnum flonum) fixnum "C_ub_i_f32vector_set")
+ (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<=
)
Trap