From f20f00916a691be4740f3d3e3008d1271608b61f Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Wed, 18 Oct 2017 13:55:54 +0200 Subject: [PATCH 1/2] Add initial version of the "scheme" module. This makes a few things more explicit and even pointed out some issues: - "cond-expand" needs to compare unhygienically, because the initial environment will contain "and", "or" and "not" from scheme, but it should work even if "scheme" is not imported, so we can't compare equality like that. The Chibi implementation (reference implementation for R7RS) also does this unhygienically. - "module" needs to compare "=" (for functor syntax) unhygienically for the same basic reason. - "Extended bindings" included things like exact-integer?, make-polar, make-rectangular, real-part, imag-part and string->symbol, which are all *standard* bindings, from r5rs. - There are still a few macros in the wrong place, like delay-force, cond-expand, require-library and letrec* - A few macro definitions were missing some mappings in their syntactic environments. Also, a few definitions from chicken.base were still unprefixed in some places, those are now prefixed. Last but not least, in a few places in compiler-syntax, the bindings checked in standard-bindings were missing their prefix, thus causing the compiler specialization to not be applied. The define-internal-compiler-syntax macro has been slightly simplified by quoting the syntax environments in the call rather than in the macro itself, and the r-c-s procedure is only used by the macro, so there's no need to make the syntactic environment argument optional: we always expand to a call that includes it. --- c-platform.scm | 475 ++++----- chicken-syntax.scm | 39 +- compiler-syntax.scm | 55 +- expand.scm | 47 +- library.scm | 2174 +++++++++++++++++++++++++---------------- modules.scm | 175 +++- scrutinizer.scm | 18 +- tests/scrutiny-2.expected | 36 +- tests/scrutiny.expected | 84 +- tests/specialization.expected | 16 +- tests/test-finalizers-2.scm | 10 +- types.db | 1276 ++++++++++++------------ 12 files changed, 2491 insertions(+), 1914 deletions(-) diff --git a/c-platform.scm b/c-platform.scm index ac9bf907..d2323fe8 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -119,26 +119,28 @@ ;;; Standard and extended bindings: (set! default-standard-bindings - '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr - cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar - cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr! - null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port - 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<=? gcd lcm reverse symbol? string->symbol - number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact? - 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=? - char-ci? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? - char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string=? string<=? string-ci=? string-ci? string-ci<=? string-ci>=? - string-append string->list list->string vector? vector->list list->vector string read - read-char substring string-fill! vector-copy! vector-fill! make-string make-vector open-input-file - open-output-file call-with-input-file call-with-output-file close-input-port close-output-port - values call-with-values vector procedure? memq memv member assq assv assoc list-tail - list-ref abs char-ready? peek-char list->string string->list - current-input-port current-output-port) ) + (map (lambda (x) (symbol-append 'scheme# x)) + '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr + cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar + cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr! + null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port + 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<=? gcd lcm reverse symbol? string->symbol + number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact? + 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=? + char-ci? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? + char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string=? string<=? string-ci=? string-ci? string-ci<=? string-ci>=? + string-append string->list list->string vector? vector->list list->vector string read + read-char substring string-fill! vector-copy! vector-fill! make-string make-vector open-input-file + open-output-file call-with-input-file call-with-output-file close-input-port close-output-port + values call-with-values vector procedure? memq memv member assq assv assoc list-tail + list-ref abs char-ready? peek-char list->string string->list + current-input-port current-output-port + make-polar make-rectangular real-part imag-part)) ) (define-constant +flonum-bindings+ (map (lambda (x) (symbol-append 'chicken.flonum# x)) @@ -163,19 +165,17 @@ 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? flush-output chicken.bitwise#integer-length chicken.bitwise#bitwise-and chicken.bitwise#bitwise-not chicken.bitwise#bitwise-ior chicken.bitwise#bitwise-xor chicken.bitwise#arithmetic-shift chicken.bitwise#bit->boolean - chicken.blob#blob-size - chicken.blob#blob=? equal=? - - exact-integer? flush-output make-polar make-rectangular - real-part imag-part string->symbol current-thread + chicken.blob#blob-size chicken.blob#blob=? chicken.keyword#get-keyword + srfi-4#u8vector-length srfi-4#s8vector-length srfi-4#u16vector-length srfi-4#s16vector-length srfi-4#u32vector-length srfi-4#u64vector-length @@ -191,6 +191,7 @@ srfi-4#blob->u32vector/shared srfi-4#blob->s32vector/shared srfi-4#blob->u64vector/shared srfi-4#blob->s64vector/shared srfi-4#blob->f32vector/shared srfi-4#blob->f64vector/shared + chicken.memory#u8vector-ref chicken.memory#s8vector-ref chicken.memory#u16vector-ref chicken.memory#s16vector-ref chicken.memory#u32vector-ref chicken.memory#s32vector-ref @@ -201,12 +202,15 @@ chicken.memory#u16vector-set! chicken.memory#s16vector-set! chicken.memory#u32vector-set! chicken.memory#s32vector-set! chicken.memory#u64vector-set! chicken.memory#s64vector-set! + chicken.memory.representation#number-of-slots chicken.memory.representation#make-record-instance chicken.memory.representation#block-ref chicken.memory.representation#block-set! + chicken.locative#locative-ref chicken.locative#locative-set! chicken.locative#locative->object chicken.locative#locative? + chicken.memory#pointer+ chicken.memory#pointer=? chicken.memory#address->pointer chicken.memory#pointer->address chicken.memory#pointer->object chicken.memory#object->pointer @@ -218,12 +222,17 @@ chicken.memory#pointer-u16-set! chicken.memory#pointer-s16-set! chicken.memory#pointer-u32-set! chicken.memory#pointer-s32-set! chicken.memory#pointer-f32-set! chicken.memory#pointer-f64-set! + chicken.string#substring-index chicken.string#substring-index-ci chicken.string#substring=? chicken.string#substring-ci=? + chicken.data-structures#identity chicken.data-structures#o chicken.data-structures#atom? chicken.data-structures#alist-ref chicken.data-structures#rassoc - chicken.io#read-string chicken.format#format + + chicken.io#read-string + + chicken.format#format chicken.format#printf chicken.format#sprintf chicken.format#fprintf)) (set! default-extended-bindings @@ -305,11 +314,11 @@ (make-node '##core#call (list #t) (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) ) - (rewrite 'eqv? 8 eqv?-id) + (rewrite 'scheme#eqv? 8 eqv?-id) (rewrite '##sys#eqv? 8 eqv?-id)) (rewrite - 'equal? 8 + 'scheme#equal? 8 (lambda (db classargs cont callargs) ;; (equal? ) -> (quote #t) ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol] @@ -363,7 +372,7 @@ '##core#call (list #t) (cons* (make-node '##core#proc '("C_apply" #t) '()) cont callargs) ) ) ) ) ) ) - (rewrite 'apply 8 rewrite-apply) + (rewrite 'scheme#apply 8 rewrite-apply) (rewrite '##sys#apply 8 rewrite-apply) ) (let () @@ -385,19 +394,19 @@ [iop1 (make-node '##core#inline (list iop1) callargs)] [else (return #f)] ) ) ) ) ) ) ) ) ) ) - (rewrite-c..r 'car "C_i_car" "C_u_i_car") + (rewrite-c..r 'scheme#car "C_i_car" "C_u_i_car") (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car") (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr") - (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr") - (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr") - (rewrite-c..r 'cadddr "C_i_cadddr" "C_u_i_cadddr") ) + (rewrite-c..r 'scheme#cadr "C_i_cadr" "C_u_i_cadr") + (rewrite-c..r 'scheme#caddr "C_i_caddr" "C_u_i_caddr") + (rewrite-c..r 'scheme#cadddr "C_i_cadddr" "C_u_i_cadddr") ) -(let ([rvalues +(let ((rvalues (lambda (db classargs cont callargs) ;; (values ) -> (and (= (length callargs) 1) - (make-node '##core#call (list #t) (cons cont callargs) ) ) ) ] ) - (rewrite 'values 8 rvalues) + (make-node '##core#call (list #t) (cons cont callargs) ) ) ) ) ) + (rewrite 'scheme#values 8 rvalues) (rewrite '##sys#values 8 rvalues) ) (let () @@ -429,79 +438,79 @@ (make-node '##core#call (list #t) (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) - (rewrite 'call-with-values 8 rewrite-c-w-v) + (rewrite 'scheme#call-with-values 8 rewrite-c-w-v) (rewrite '##sys#call-with-values 8 rewrite-c-w-v) ) -(rewrite 'values 13 #f "C_values" #t) +(rewrite 'scheme#values 13 #f "C_values" #t) (rewrite '##sys#values 13 #f "C_values" #t) -(rewrite 'call-with-values 13 2 "C_u_call_with_values" #f) -(rewrite 'call-with-values 13 2 "C_call_with_values" #t) +(rewrite 'scheme#call-with-values 13 2 "C_u_call_with_values" #f) +(rewrite 'scheme#call-with-values 13 2 "C_call_with_values" #t) (rewrite '##sys#call-with-values 13 2 "C_u_call_with_values" #f) (rewrite '##sys#call-with-values 13 2 "C_call_with_values" #t) (rewrite 'chicken.continuation#continuation-graft 13 2 "C_continuation_graft" #t) -(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 'caar 2 1 "C_i_caar" #t) -(rewrite 'cdar 2 1 "C_i_cdar" #t) -(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) - -(rewrite 'eq? 1 2 "C_eqp") +(rewrite 'scheme#caar 2 1 "C_u_i_caar" #f) +(rewrite 'scheme#cdar 2 1 "C_u_i_cdar" #f) +(rewrite 'scheme#cddr 2 1 "C_u_i_cddr" #f) +(rewrite 'scheme#caaar 2 1 "C_u_i_caaar" #f) +(rewrite 'scheme#cadar 2 1 "C_u_i_cadar" #f) +(rewrite 'scheme#caddr 2 1 "C_u_i_caddr" #f) +(rewrite 'scheme#cdaar 2 1 "C_u_i_cdaar" #f) +(rewrite 'scheme#cdadr 2 1 "C_u_i_cdadr" #f) +(rewrite 'scheme#cddar 2 1 "C_u_i_cddar" #f) +(rewrite 'scheme#cdddr 2 1 "C_u_i_cdddr" #f) +(rewrite 'scheme#caaaar 2 1 "C_u_i_caaaar" #f) +(rewrite 'scheme#caadar 2 1 "C_u_i_caadar" #f) +(rewrite 'scheme#caaddr 2 1 "C_u_i_caaddr" #f) +(rewrite 'scheme#cadaar 2 1 "C_u_i_cadaar" #f) +(rewrite 'scheme#cadadr 2 1 "C_u_i_cadadr" #f) +(rewrite 'scheme#caddar 2 1 "C_u_i_caddar" #f) +(rewrite 'scheme#cadddr 2 1 "C_u_i_cadddr" #f) +(rewrite 'scheme#cdaaar 2 1 "C_u_i_cdaaar" #f) +(rewrite 'scheme#cdaadr 2 1 "C_u_i_cdaadr" #f) +(rewrite 'scheme#cdadar 2 1 "C_u_i_cdadar" #f) +(rewrite 'scheme#cdaddr 2 1 "C_u_i_cdaddr" #f) +(rewrite 'scheme#cddaar 2 1 "C_u_i_cddaar" #f) +(rewrite 'scheme#cddadr 2 1 "C_u_i_cddadr" #f) +(rewrite 'scheme#cdddar 2 1 "C_u_i_cdddar" #f) +(rewrite 'scheme#cddddr 2 1 "C_u_i_cddddr" #f) + +(rewrite 'scheme#caar 2 1 "C_i_caar" #t) +(rewrite 'scheme#cdar 2 1 "C_i_cdar" #t) +(rewrite 'scheme#cddr 2 1 "C_i_cddr" #t) +(rewrite 'scheme#cdddr 2 1 "C_i_cdddr" #t) +(rewrite 'scheme#cddddr 2 1 "C_i_cddddr" #t) + +(rewrite 'scheme#cdr 7 1 "C_slot" 1 #f) +(rewrite 'scheme#cdr 2 1 "C_i_cdr" #t) + +(rewrite 'scheme#eq? 1 2 "C_eqp") (rewrite '##sys#eq? 1 2 "C_eqp") -(rewrite 'eqv? 1 2 "C_i_eqvp") +(rewrite 'scheme#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) -(rewrite 'list-ref 2 2 "C_i_list_ref" #t) -(rewrite 'null? 2 1 "C_i_nullp" #t) +(rewrite 'scheme#list-ref 2 2 "C_u_i_list_ref" #f) +(rewrite 'scheme#list-ref 2 2 "C_i_list_ref" #t) +(rewrite 'scheme#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 'scheme#length 2 1 "C_i_length" #t) +(rewrite 'scheme#not 2 1 "C_i_not"#t ) +(rewrite 'scheme#char? 2 1 "C_charp" #t) +(rewrite 'scheme#string? 2 1 "C_i_stringp" #t) (rewrite 'chicken.locative#locative? 2 1 "C_i_locativep" #t) -(rewrite 'symbol? 2 1 "C_i_symbolp" #t) -(rewrite 'vector? 2 1 "C_i_vectorp" #t) +(rewrite 'scheme#symbol? 2 1 "C_i_symbolp" #t) +(rewrite 'scheme#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 'scheme#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_realp" #t) -(rewrite 'integer? 2 1 "C_i_integerp" #t) +(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t) +(rewrite 'scheme#port? 2 1 "C_i_portp" #t) +(rewrite 'scheme#boolean? 2 1 "C_booleanp" #t) +(rewrite 'scheme#number? 2 1 "C_i_numberp" #t) +(rewrite 'scheme#complex? 2 1 "C_i_numberp" #t) +(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 'chicken.base#flonum? 2 1 "C_i_flonump" #t) (rewrite 'chicken.base#fixnum? 2 1 "C_fixnump" #t) @@ -515,29 +524,28 @@ (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_i_exactp" #t) -(rewrite 'exact? 2 1 "C_u_i_exactp" #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_u_i_char_equalp" #f) -(rewrite 'char=? 2 2 "C_i_char_equalp" #t) -(rewrite 'char>? 2 2 "C_u_i_char_greaterp" #f) -(rewrite 'char>? 2 2 "C_i_char_greaterp" #t) -(rewrite 'char=? 2 2 "C_u_i_char_greater_or_equal_p" #f) -(rewrite 'char>=? 2 2 "C_i_char_greater_or_equal_p" #t) -(rewrite 'char<=? 2 2 "C_u_i_char_less_or_equal_p" #f) -(rewrite 'char<=? 2 2 "C_i_char_less_or_equal_p" #t) +(rewrite 'scheme#exact? 2 1 "C_i_exactp" #t) +(rewrite 'scheme#exact? 2 1 "C_u_i_exactp" #f) +(rewrite 'scheme#inexact? 2 1 "C_i_inexactp" #t) +(rewrite 'scheme#inexact? 2 1 "C_u_i_inexactp" #f) +(rewrite 'scheme#list? 2 1 "C_i_listp" #t) +(rewrite 'scheme#eof-object? 2 1 "C_eofp" #t) +(rewrite 'scheme#string-ref 2 2 "C_subchar" #f) +(rewrite 'scheme#string-ref 2 2 "C_i_string_ref" #t) +(rewrite 'scheme#string-set! 2 3 "C_setsubchar" #f) +(rewrite 'scheme#string-set! 2 3 "C_i_string_set" #t) +(rewrite 'scheme#vector-ref 2 2 "C_slot" #f) +(rewrite 'scheme#vector-ref 2 2 "C_i_vector_ref" #t) +(rewrite 'scheme#char=? 2 2 "C_u_i_char_equalp" #f) +(rewrite 'scheme#char=? 2 2 "C_i_char_equalp" #t) +(rewrite 'scheme#char>? 2 2 "C_u_i_char_greaterp" #f) +(rewrite 'scheme#char>? 2 2 "C_i_char_greaterp" #t) +(rewrite 'scheme#char=? 2 2 "C_u_i_char_greater_or_equal_p" #f) +(rewrite 'scheme#char>=? 2 2 "C_i_char_greater_or_equal_p" #t) +(rewrite 'scheme#char<=? 2 2 "C_u_i_char_less_or_equal_p" #f) +(rewrite 'scheme#char<=? 2 2 "C_i_char_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) ;XXX must be safe for pattern matcher (anymore?) (rewrite '##sys#size 2 1 "C_block_size" #t) @@ -563,34 +571,34 @@ (rewrite 'chicken.flonum#fpmin 2 2 "C_i_flonum_min" #f) (rewrite 'chicken.fixnum#fxgcd 2 2 "C_i_fixnum_gcd" #t) (rewrite 'chicken.fixnum#fxlen 2 1 "C_i_fixnum_length" #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 'scheme#char-numeric? 2 1 "C_u_i_char_numericp" #t) +(rewrite 'scheme#char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t) +(rewrite 'scheme#char-whitespace? 2 1 "C_u_i_char_whitespacep" #t) +(rewrite 'scheme#char-upper-case? 2 1 "C_u_i_char_upper_casep" #t) +(rewrite 'scheme#char-lower-case? 2 1 "C_u_i_char_lower_casep" #t) +(rewrite 'scheme#char-upcase 2 1 "C_u_i_char_upcase" #t) +(rewrite 'scheme#char-downcase 2 1 "C_u_i_char_downcase" #t) +(rewrite 'scheme#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 'chicken.memory.representation#block-ref 2 2 "C_slot" #f) ; ok to be unsafe, lolevel is anyway (rewrite 'chicken.memory.representation#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) -(rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq") -(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) -(rewrite 'member 2 2 "C_i_member" #t) +(rewrite 'scheme#assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq") +(rewrite 'scheme#assv 2 2 "C_i_assv" #t) +(rewrite 'scheme#memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq") +(rewrite 'scheme#memv 2 2 "C_i_memv" #t) +(rewrite 'scheme#assq 17 2 "C_i_assq" "C_u_i_assq") +(rewrite 'scheme#memq 17 2 "C_i_memq" "C_u_i_memq") +(rewrite 'scheme#assoc 2 2 "C_i_assoc" #t) +(rewrite 'scheme#member 2 2 "C_i_member" #t) -(rewrite 'set-car! 4 '##sys#setslot 0) -(rewrite 'set-cdr! 4 '##sys#setslot 1) -(rewrite 'set-car! 17 2 "C_i_set_car" "C_u_i_set_car") -(rewrite 'set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr") +(rewrite 'scheme#set-car! 4 '##sys#setslot 0) +(rewrite 'scheme#set-cdr! 4 '##sys#setslot 1) +(rewrite 'scheme#set-car! 17 2 "C_i_set_car" "C_u_i_set_car") +(rewrite 'scheme#set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr") -(rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs") +(rewrite 'scheme#abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs") (rewrite 'chicken.bitwise#bitwise-and 19) (rewrite 'chicken.bitwise#bitwise-xor 19) @@ -610,24 +618,24 @@ (rewrite 'chicken.flonum#fpneg 16 1 "C_a_i_flonum_negate" #f words-per-flonum) (rewrite 'chicken.flonum#fpgcd 16 2 "C_a_i_flonum_gcd" #f words-per-flonum) -(rewrite 'zero? 5 "C_eqp" 0 'fixnum) -(rewrite 'zero? 2 1 "C_u_i_zerop" #f) -(rewrite 'zero? 2 1 "C_i_zerop" #t) -(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum) -(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum) -(rewrite 'positive? 2 1 "C_i_positivep" #t) -(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum) -(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum) -(rewrite 'negative? 2 1 "C_i_negativep" #t) - -(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) +(rewrite 'scheme#zero? 5 "C_eqp" 0 'fixnum) +(rewrite 'scheme#zero? 2 1 "C_u_i_zerop" #f) +(rewrite 'scheme#zero? 2 1 "C_i_zerop" #t) +(rewrite 'scheme#positive? 5 "C_fixnum_greaterp" 0 'fixnum) +(rewrite 'scheme#positive? 5 "C_flonum_greaterp" 0 'flonum) +(rewrite 'scheme#positive? 2 1 "C_i_positivep" #t) +(rewrite 'scheme#negative? 5 "C_fixnum_lessp" 0 'fixnum) +(rewrite 'scheme#negative? 5 "C_flonum_lessp" 0 'flonum) +(rewrite 'scheme#negative? 2 1 "C_i_negativep" #t) + +(rewrite 'scheme#vector-length 6 "C_fix" "C_header_size" #f) +(rewrite 'scheme#string-length 6 "C_fix" "C_header_size" #f) +(rewrite 'scheme#char->integer 6 "C_fix" "C_character_code" #t) +(rewrite 'scheme#integer->char 6 "C_make_character" "C_unfix" #t) + +(rewrite 'scheme#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 'scheme#string-length 2 1 "C_i_string_length" #t) (rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t) (rewrite '##sys#check-fixnum 2 1 "C_i_check_fixnum" #t) @@ -656,66 +664,66 @@ (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) -(rewrite '< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f) -(rewrite '>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f) -(rewrite '<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f) +(rewrite 'scheme#= 9 "C_eqp" "C_i_equalp" #t #t) +(rewrite 'scheme#> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f) +(rewrite 'scheme#< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f) +(rewrite 'scheme#>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f) +(rewrite 'scheme#<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f) (rewrite 'setter 11 1 '##sys#setter #t) -(rewrite 'for-each 11 2 '##sys#for-each #t) -(rewrite 'map 11 2 '##sys#map #t) +(rewrite 'scheme#for-each 11 2 '##sys#for-each #t) +(rewrite 'scheme#map 11 2 '##sys#map #t) (rewrite 'chicken.memory.representation#block-set! 11 3 '##sys#setslot #t) (rewrite '##sys#block-set! 11 3 '##sys#setslot #f) (rewrite 'chicken.memory.representation#make-record-instance 11 #f '##sys#make-structure #f) -(rewrite 'substring 11 3 '##sys#substring #f) -(rewrite 'string-append 11 2 '##sys#string-append #f) -(rewrite 'string->list 11 1 '##sys#string->list #t) -(rewrite 'list->string 11 1 '##sys#list->string #t) +(rewrite 'scheme#substring 11 3 '##sys#substring #f) +(rewrite 'scheme#string-append 11 2 '##sys#string-append #f) +(rewrite 'scheme#string->list 11 1 '##sys#string->list #t) +(rewrite 'scheme#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) +(rewrite 'scheme#vector-set! 11 3 '##sys#setslot #f) +(rewrite 'scheme#vector-set! 2 3 "C_i_vector_set" #t) -(rewrite 'gcd 12 '##sys#gcd #t 2) -(rewrite 'lcm 12 '##sys#lcm #t 2) +(rewrite 'scheme#gcd 12 '##sys#gcd #t 2) +(rewrite 'scheme#lcm 12 '##sys#lcm #t 2) (rewrite 'chicken.data-structures#identity 12 #f #t 1) -(rewrite 'gcd 19) -(rewrite 'lcm 19) - -(rewrite 'gcd 18 0) -(rewrite 'lcm 18 1) -(rewrite 'list 18 '()) - -(rewrite '+ 19) -(rewrite '- 19) -(rewrite '* 19) -(rewrite '/ 19) - -(rewrite '+ 16 2 "C_s_a_i_plus" #t 29) -(rewrite '- 16 2 "C_s_a_i_minus" #t 29) -(rewrite '* 16 2 "C_s_a_i_times" #t 33) -(rewrite 'quotient 16 2 "C_s_a_i_quotient" #t 5) -(rewrite 'remainder 16 2 "C_s_a_i_remainder" #t 5) -(rewrite 'modulo 16 2 "C_s_a_i_modulo" #t 5) - -(rewrite '= 17 2 "C_i_nequalp") -(rewrite '> 17 2 "C_i_greaterp") -(rewrite '< 17 2 "C_i_lessp") -(rewrite '>= 17 2 "C_i_greater_or_equalp") -(rewrite '<= 17 2 "C_i_less_or_equalp") - -(rewrite '= 13 #f "C_nequalp" #t) -(rewrite '> 13 #f "C_greaterp" #t) -(rewrite '< 13 #f "C_lessp" #t) -(rewrite '>= 13 #f "C_greater_or_equal_p" #t) -(rewrite '<= 13 #f "C_less_or_equal_p" #t) - -(rewrite '* 13 #f "C_times" #t) -(rewrite '+ 13 #f "C_plus" #t) -(rewrite '- 13 '(1 . #f) "C_minus" #t) - -(rewrite 'number->string 13 '(1 . 2) "C_number_to_string" #t) +(rewrite 'scheme#gcd 19) +(rewrite 'scheme#lcm 19) + +(rewrite 'scheme#gcd 18 0) +(rewrite 'scheme#lcm 18 1) +(rewrite 'scheme#list 18 '()) + +(rewrite 'scheme#+ 19) +(rewrite 'scheme#- 19) +(rewrite 'scheme#* 19) +(rewrite 'scheme#/ 19) + +(rewrite 'scheme#+ 16 2 "C_s_a_i_plus" #t 29) +(rewrite 'scheme#- 16 2 "C_s_a_i_minus" #t 29) +(rewrite 'scheme#* 16 2 "C_s_a_i_times" #t 33) +(rewrite 'scheme#quotient 16 2 "C_s_a_i_quotient" #t 5) +(rewrite 'scheme#remainder 16 2 "C_s_a_i_remainder" #t 5) +(rewrite 'scheme#modulo 16 2 "C_s_a_i_modulo" #t 5) + +(rewrite 'scheme#= 17 2 "C_i_nequalp") +(rewrite 'scheme#> 17 2 "C_i_greaterp") +(rewrite 'scheme#< 17 2 "C_i_lessp") +(rewrite 'scheme#>= 17 2 "C_i_greater_or_equalp") +(rewrite 'scheme#<= 17 2 "C_i_less_or_equalp") + +(rewrite 'scheme#= 13 #f "C_nequalp" #t) +(rewrite 'scheme#> 13 #f "C_greaterp" #t) +(rewrite 'scheme#< 13 #f "C_lessp" #t) +(rewrite 'scheme#>= 13 #f "C_greater_or_equal_p" #t) +(rewrite 'scheme#<= 13 #f "C_less_or_equal_p" #t) + +(rewrite 'scheme#* 13 #f "C_times" #t) +(rewrite 'scheme#+ 13 #f "C_plus" #t) +(rewrite 'scheme#- 13 '(1 . #f) "C_minus" #t) + +(rewrite 'scheme#number->string 13 '(1 . 2) "C_number_to_string" #t) (rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t) (rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t) (rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t) @@ -724,19 +732,19 @@ (rewrite '##sys#intern-symbol 13 1 "C_string_to_symbol" #t) (rewrite '##sys#make-symbol 13 1 "C_make_symbol" #t) -(rewrite 'even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp") -(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp") -(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo") +(rewrite 'scheme#even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp") +(rewrite 'scheme#odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp") +(rewrite 'scheme#remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo") -(rewrite 'even? 17 1 "C_i_evenp") -(rewrite 'odd? 17 1 "C_i_oddp") +(rewrite 'scheme#even? 17 1 "C_i_evenp") +(rewrite 'scheme#odd? 17 1 "C_i_oddp") (rewrite 'chicken.fixnum#fxodd? 2 1 "C_i_fixnumoddp" #t) (rewrite 'chicken.fixnum#fxeven? 2 1 "C_i_fixnumevenp" #t) -(rewrite 'floor 15 'flonum 'fixnum 'chicken.flonum#fpfloor #f) -(rewrite 'ceiling 15 'flonum 'fixnum 'chicken.flonum#fpceiling #f) -(rewrite 'truncate 15 'flonum 'fixnum 'chicken.flonum#fptruncate #f) +(rewrite 'scheme#floor 15 'flonum 'fixnum 'chicken.flonum#fpfloor #f) +(rewrite 'scheme#ceiling 15 'flonum 'fixnum 'chicken.flonum#fpceiling #f) +(rewrite 'scheme#truncate 15 'flonum 'fixnum 'chicken.flonum#fptruncate #f) (rewrite 'chicken.flonum#fpsin 16 1 "C_a_i_flonum_sin" #f words-per-flonum) (rewrite 'chicken.flonum#fpcos 16 1 "C_a_i_flonum_cos" #f words-per-flonum) @@ -755,14 +763,14 @@ (rewrite 'chicken.flonum#fpceiling 16 1 "C_a_i_flonum_ceiling" #f words-per-flonum) (rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_floor" #f words-per-flonum) -(rewrite 'cons 16 2 "C_a_i_cons" #t 3) +(rewrite 'scheme#cons 16 2 "C_a_i_cons" #t 3) (rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3) -(rewrite 'list 16 #f "C_a_i_list" #t '(0 3) #t) +(rewrite 'scheme#list 16 #f "C_a_i_list" #t '(0 3) #t) (rewrite '##sys#list 16 #f "C_a_i_list" #t '(0 3)) -(rewrite 'vector 16 #f "C_a_i_vector" #t #t #t) +(rewrite 'scheme#vector 16 #f "C_a_i_vector" #t #t #t) (rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t) (rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t #t) -(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care +(rewrite 'scheme#string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care (rewrite 'chicken.memory#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2) (rewrite 'chicken.memory#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum) (rewrite 'chicken.memory#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2) @@ -858,8 +866,8 @@ (rewrite '##sys#setislot 17 3 "C_i_set_i_slot") (rewrite '##sys#poke-integer 17 3 "C_poke_integer") (rewrite '##sys#poke-double 17 3 "C_poke_double") -(rewrite 'string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p") -(rewrite 'string-ci=? 17 2 "C_i_string_ci_equal_p") +(rewrite 'scheme#string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p") +(rewrite 'scheme#string-ci=? 17 2 "C_i_string_ci_equal_p") (rewrite '##sys#permanent? 17 1 "C_permanentp") (rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp") (rewrite '##sys#immediate? 17 1 "C_immp") @@ -947,7 +955,7 @@ '##core#inline_allocate (list "C_a_i_vector" (add1 c)) (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) - (rewrite 'make-vector 8 rewrite-make-vector) + (rewrite 'scheme#make-vector 8 rewrite-make-vector) (rewrite '##sys#make-vector 8 rewrite-make-vector) ) (let () @@ -970,14 +978,14 @@ (make-node '##core#call (list #t) (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) ) - (rewrite 'call-with-current-continuation 8 rewrite-call/cc) + (rewrite 'scheme#call-with-current-continuation 8 rewrite-call/cc) (rewrite 'chicken.base#call/cc 8 rewrite-call/cc)) (define setter-map - '((car . set-car!) - (cdr . set-cdr!) - (string-ref . string-set!) - (vector-ref . vector-set!) + '((scheme#car . scheme#set-car!) + (scheme#cdr . scheme#set-cdr!) + (scheme#string-ref . scheme#string-set!) + (scheme#vector-ref . scheme#vector-set!) (srfi-4#u8vector-ref . srfi-4#u8vector-set!) (srfi-4#s8vector-ref . srfi-4#s8vector-set!) (srfi-4#u16vector-ref . srfi-4#u16vector-set!) @@ -1013,12 +1021,11 @@ '##core#call (list #t) (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) ) -(rewrite 'void 3 '##sys#undefined-value 0) +(rewrite 'chicken.base#void 3 '##sys#undefined-value 0) (rewrite '##sys#void 3 '##sys#undefined-value #f) -(rewrite 'current-thread 3 '##sys#current-thread 0) -(rewrite 'current-input-port 3 '##sys#standard-input 0) -(rewrite 'current-output-port 3 '##sys#standard-output 0) -(rewrite 'current-error-port 3 '##sys#standard-error 0) +(rewrite 'scheme#current-input-port 3 '##sys#standard-input 0) +(rewrite 'scheme#current-output-port 3 '##sys#standard-output 0) +(rewrite 'chicken.base#current-error-port 3 '##sys#standard-error 0) (rewrite 'chicken.bitwise#bit->boolean 8 @@ -1044,8 +1051,8 @@ (list (if (eq? number-type 'fixnum) "C_i_fixnum_length" "C_i_integer_length")) callargs) ) ) ) ) ) -(rewrite 'read-char 23 0 '##sys#read-char/port '##sys#standard-input) -(rewrite 'write-char 23 1 '##sys#write-char/port '##sys#standard-output) +(rewrite 'scheme#read-char 23 0 '##sys#read-char/port '##sys#standard-input) +(rewrite 'scheme#write-char 23 1 '##sys#write-char/port '##sys#standard-output) (rewrite 'chicken.io#read-string 23 1 'chicken.io#read-string/port '##sys#standard-input) (rewrite 'chicken.string#substring=? 23 2 '##sys#substring=? 0 0 #f) (rewrite 'chicken.string#substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index ca0dcdfb..a2f3c800 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -50,7 +50,7 @@ (##sys#extend-macro-environment 'handle-exceptions - `((call-with-current-continuation . ,(##sys#primitive-alias 'call-with-current-continuation))) + `((call-with-current-continuation . scheme#call-with-current-continuation)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'handle-exceptions form '(_ variable _ . _)) @@ -72,7 +72,7 @@ (##sys#extend-macro-environment 'condition-case `((else . ,(##sys#primitive-alias 'else)) - (memv . ,(##sys#primitive-alias 'memv))) + (memv . scheme#memv)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'condition-case form '(_ _ . _)) @@ -613,7 +613,7 @@ (##sys#extend-macro-environment 'nth-value - `((list-ref . ,(##sys#primitive-alias 'list-ref))) + `((list-ref . scheme#list-ref)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'nth-value form '(_ _ _)) @@ -742,8 +742,9 @@ (##sys#extend-macro-environment 'let-optionals - `((car . ,(##sys#primitive-alias 'car)) - (cdr . ,(##sys#primitive-alias 'cdr))) + `((null? . scheme#null?) + (car . scheme#car) + (cdr . scheme#cdr)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'let-optionals form '(_ _ . _)) @@ -777,7 +778,7 @@ (if (null? vars) `(,body-proc . ,(reverse non-defaults)) (let ((v (car vars))) - `(##core#if (null? ,rest) + `(##core#if (,(r 'null?) ,rest) (,(car defaulters) . ,(reverse non-defaults)) (##core#let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization (,rest (,(r 'cdr) ,rest))) @@ -830,9 +831,9 @@ (##sys#extend-macro-environment 'optional - `((null? . ,(##sys#primitive-alias 'null?)) - (car . ,(##sys#primitive-alias 'car)) - (cdr . ,(##sys#primitive-alias 'cdr)) ) + `((null? . scheme#null?) + (car . scheme#car) + (cdr . scheme#cdr) ) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1))) @@ -858,9 +859,9 @@ (##sys#extend-macro-environment 'let-optionals* - `((null? . ,(##sys#primitive-alias 'null?)) - (car . ,(##sys#primitive-alias 'car)) - (cdr . ,(##sys#primitive-alias 'cdr))) + `((null? . scheme#null?) + (car . scheme#car) + (cdr . scheme#cdr)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'let-optionals* form '(_ _ list . _)) @@ -893,11 +894,11 @@ (##sys#extend-macro-environment 'case-lambda - `((>= . ,(##sys#primitive-alias '>=)) - (car . ,(##sys#primitive-alias 'car)) - (cdr . ,(##sys#primitive-alias 'cdr)) - (eq? . ,(##sys#primitive-alias 'eq?)) - (length . ,(##sys#primitive-alias 'length))) + `((>= . scheme#>=) + (car . scheme#car) + (cdr . scheme#cdr) + (eq? . scheme#eq?) + (length . scheme#length)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'case-lambda form '(_ . _)) @@ -1075,7 +1076,7 @@ (##sys#extend-macro-environment 'cut - `((apply . ,(##sys#primitive-alias 'apply))) + `((apply . scheme#apply)) (##sys#er-transformer (lambda (form r c) (let ((%<> (r '<>)) @@ -1108,7 +1109,7 @@ (##sys#extend-macro-environment 'cute - `((apply . ,(##sys#primitive-alias 'apply))) + `((apply . scheme#apply)) (##sys#er-transformer (lambda (form r c) (let ((%apply (r 'apply)) diff --git a/compiler-syntax.scm b/compiler-syntax.scm index 1311b0c0..7a15de57 100644 --- a/compiler-syntax.scm +++ b/compiler-syntax.scm @@ -51,7 +51,7 @@ (set! compiler-syntax-statistics (alist-update! name (add1 a) compiler-syntax-statistics))))) -(define (r-c-s names transformer #!optional (se '())) +(define (r-c-s names transformer se) (let ((t (cons (##sys#ensure-transformer (##sys#er-transformer transformer) (car names)) @@ -63,13 +63,11 @@ (define-syntax define-internal-compiler-syntax (syntax-rules () - ((_ (names . llist) (se ...) . body) - (r-c-s - 'names (lambda llist . body) - `((se . ,(##sys#primitive-alias 'se)) ...))))) + ((_ (names . llist) se . body) + (r-c-s 'names (lambda llist . body) se)))) -(define-internal-compiler-syntax ((for-each ##sys#for-each #%for-each) x r c) - (pair?) +(define-internal-compiler-syntax ((scheme#for-each ##sys#for-each #%for-each) x r c) + '((pair? . scheme#pair?)) (let ((%let (r 'let)) (%if (r 'if)) (%loop (r 'for-each-loop)) @@ -80,7 +78,7 @@ (%pair? (r 'pair?)) (%lambda (r 'lambda)) (lsts (cddr x))) - (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus + (if (and (memq 'scheme#for-each standard-bindings) ; we have to check this because the db (and thus (> (length+ x) 2)) ; intrinsic marks) isn't set up yet (let ((vars (map (lambda _ (gensym)) lsts))) `(,%let ((,%proc ,(cadr x)) @@ -98,8 +96,8 @@ ,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) ))))) x))) -(define-internal-compiler-syntax ((map ##sys#map #%map) x r c) - (pair? cons) +(define-internal-compiler-syntax ((scheme#map ##sys#map #%map) x r c) + '((pair? . scheme#pair?) (cons . scheme#cons)) (let ((%let (r 'let)) (%if (r 'if)) (%loop (r 'map-loop)) @@ -115,7 +113,7 @@ (%and (r 'and)) (%pair? (r 'pair?)) (lsts (cddr x))) - (if (and (memq 'map standard-bindings) ; s.a. + (if (and (memq 'scheme#map standard-bindings) ; s.a. (> (length+ x) 2)) (let ((vars (map (lambda _ (gensym)) lsts))) `(,%let ((,%node (,%cons (##core#undefined) (,%quote ())))) @@ -140,7 +138,7 @@ (##sys#slot ,%result 1)))))) x))) -(define-internal-compiler-syntax ((chicken.data-structures#o) x r c) () +(define-internal-compiler-syntax ((chicken.data-structures#o) x r c) '() (if (and (fx> (length x) 1) (memq 'chicken.data-structures#o extended-bindings)) ; s.a. (let ((%tmp (r 'tmp))) @@ -148,7 +146,12 @@ x)) (define-internal-compiler-syntax ((chicken.format#sprintf chicken.format#format) x r c) - (display write number->string write-char open-output-string get-output-string) + `((display . scheme#display) + (write . scheme#write) + (number->string . scheme#number->string) + (write-char . scheme#write-char) + (open-output-string . ,(##sys#primitive-alias 'open-output-string)) + (get-output-string . ,(##sys#primitive-alias 'get-output-string))) (let* ((out (gensym 'out)) (code (compile-format-string (if (eq? (car x) 'chicken.format#sprintf) 'sprintf 'format) @@ -160,14 +163,24 @@ x))) (define-internal-compiler-syntax ((chicken.format#fprintf) x r c) - (display write number->string write-char open-output-string get-output-string) + '((display . scheme#display) + (write . scheme#write) + (number->string . scheme#number->string) + (write-char . scheme#write-char) + (open-output-string . ,(##sys#primitive-alias 'open-output-string)) + (get-output-string . ,(##sys#primitive-alias 'get-output-string))) (if (>= (length x) 3) (let ((code (compile-format-string 'fprintf (cadr x) x (cddr x) r c))) (or code x)) x)) (define-internal-compiler-syntax ((chicken.format#printf) x r c) - (display write number->string write-char open-output-string get-output-string) + '((display . scheme#display) + (write . scheme#write) + (number->string . scheme#number->string) + (write-char . scheme#write-char) + (open-output-string . ,(##sys#primitive-alias 'open-output-string)) + (get-output-string . ,(##sys#primitive-alias 'get-output-string))) (let ((code (compile-format-string 'printf '##sys#standard-output x (cdr x) r c))) (or code x))) @@ -260,10 +273,10 @@ (loop '()) ) (loop (cons c chunk))))))))))))) -(define-internal-compiler-syntax ((foldr #%foldr) x r c) - (pair?) +(define-internal-compiler-syntax ((chicken.base#foldr #%foldr) x r c) + '((pair? . scheme#pair?)) (if (and (fx= (length x) 4) - (memq 'foldr extended-bindings) ) ; s.a. + (memq 'chicken.base#foldr extended-bindings) ) ; s.a. (let ((f (cadr x)) (z (caddr x)) (lst (cadddr x)) @@ -282,10 +295,10 @@ ,z)))) x)) -(define-internal-compiler-syntax ((foldl #%foldl) x r c) - (pair?) +(define-internal-compiler-syntax ((chicken.base#foldl #%foldl) x r c) + '((pair? . scheme#pair?)) (if (and (fx= (length x) 4) - (memq 'foldl extended-bindings) ) ; s.a. + (memq 'chicken.base#foldl extended-bindings) ) ; s.a. (let ((f (cadr x)) (z (caddr x)) (lst (cadddr x)) diff --git a/expand.scm b/expand.scm index b2044d9a..b6c763b6 100644 --- a/expand.scm +++ b/expand.scm @@ -1014,7 +1014,13 @@ (##sys#check-syntax 'module x '(_ _ _ . #(_ 0))) (let ((len (length x)) (name (library-id (cadr x)))) - (cond ((and (fx>= len 4) (c (r '=) (caddr x))) + ;; We strip syntax here instead of doing a hygienic comparison + ;; to "=". This is a tradeoff; either we do this, or we must + ;; include a mapping of (= . scheme#=) in our syntax env. In + ;; the initial environment, = is bound to scheme#=, but when + ;; using -explicit-use that's not the case. Doing an unhygienic + ;; comparison ensures module will work in both cases. + (cond ((and (fx>= len 4) (eq? '= (strip-syntax (caddr x)))) (let* ((x (strip-syntax x)) (app (cadddr x))) (cond ((fx> len 4) @@ -1393,7 +1399,7 @@ (##sys#extend-macro-environment 'case - '() + '((eqv? . scheme#eqv?)) (##sys#er-transformer (lambda (form r c) (##sys#check-syntax 'case form '(_ _ . #(_ 0))) @@ -1550,11 +1556,7 @@ '() (##sys#er-transformer (lambda (form r c) - (let ((clauses (cdr form)) - (%or (r 'or)) - (%not (r 'not)) - (%else (r 'else)) - (%and (r 'and))) + (let ((clauses (cdr form))) (define (err x) (##sys#error "syntax error in `cond-expand' form" x @@ -1565,20 +1567,21 @@ (else (let ((head (car fx)) (rest (cdr fx))) - (cond ((c %and head) - (or (eq? rest '()) - (if (pair? rest) - (and (test (car rest)) - (test `(,%and ,@(cdr rest))) ) - (err fx) ) ) ) - ((c %or head) - (and (not (eq? rest '())) - (if (pair? rest) - (or (test (car rest)) - (test `(,%or ,@(cdr rest))) ) - (err fx) ) ) ) - ((c %not head) (not (test (cadr fx)))) - (else (err fx)) ) ) ) ) ) + (case (strip-syntax head) + ((and) + (or (eq? rest '()) + (if (pair? rest) + (and (test (car rest)) + (test `(and ,@(cdr rest))) ) + (err fx) ) ) ) + ((or) + (and (not (eq? rest '())) + (if (pair? rest) + (or (test (car rest)) + (test `(or ,@(cdr rest))) ) + (err fx) ) ) ) + ((not) (not (test (cadr fx)))) + (else (err fx)) ) ) ) ) ) (let expand ((cls clauses)) (cond ((eq? cls '()) (##sys#apply @@ -1591,7 +1594,7 @@ (if (not (pair? clause)) (err clause) (let ((id (car clause))) - (cond ((c id %else) + (cond ((eq? (strip-syntax id) 'else) (let ((rest (cdr clause))) (if (eq? rest '()) '(##core#undefined) diff --git a/library.scm b/library.scm index 50f80aaa..d7c9387e 100644 --- a/library.scm +++ b/library.scm @@ -178,12 +178,392 @@ signal_debug_event(C_word mode, C_word msg, C_word args) EOF ) ) -;; Pre-declaration of chicken.base, so it can be used later on. Many -;; declarations will be set! further down in this file, mostly to -;; avoid a cyclic dependency on itself (only pure Scheme and core -;; language operations are allowed in here). Also, this declaration -;; is incomplete: the module itself is defined as a primitive module -;; due to syntax exports, which are missing here. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; NOTE: Modules defined here will typically exclude syntax +;; definitions, those are handled by expand.scm or modules.scm. +;; Handwritten import libraries (or a special-case module in +;; modules.scm for scheme) contains the value exports merged with +;; syntactic exports. The upshot of this is that any module that +;; refers to another module defined *earlier* in this file cannot use +;; macros from the earlier module! + +;; We get around that problem for now by using "chicken" when +;; importing things like "when", "unless" from chicken.base, +;; "handle-exceptions" from chicken.condition. For "scheme" there's a +;; workaround available: we import r5rs-null which contains only the +;; syntactic definitions from r5rs and reexport it straight away in +;; this file, so that we may use at least the scheme definitions +;; normally. For other modules, this still is a major TODO! Also, the +;; scheme module contains too many syntactic definitions, which is +;; also a TODO. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Pre-declaration of scheme, so it can be used later on. We only use +;; scheme macros and core language forms in here, to avoid a cyclic +;; dependency on itself. All actual definitions are set! below. +;; Also, this declaration is incomplete: the module itself is defined +;; as a primitive module due to syntax exports, which are missing +;; here. See modules.scm for the full definition. +(module scheme + (;; [syntax] + ;; We are reexporting these because otherwise the module here + ;; will be inconsistent with the built-in one, and be void of + ;; syntax definitions, causing problems below. + lambda quote syntax if begin define define-syntax + let letrec letrec* let-syntax letrec-syntax set! and or cond + case let* do quasiquote delay + ;; TODO: Better control the set of macros exported by "scheme" + ;; The following are not standard macros! + delay-force cond-expand require-library syntax-rules + + not boolean? eq? eqv? equal? pair? + cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar + cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar + cddddr set-car! set-cdr! + null? list? list length list-tail list-ref append reverse memq memv + 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 + modulo gcd lcm abs floor ceiling truncate round rationalize + exact->inexact inexact->exact exp log expt sqrt + sin cos tan asin acos atan + number->string string->number char? char=? char>? char=? + char<=? char-ci=? char-ci? char-ci>=? char-ci<=? + char-alphabetic? char-whitespace? char-numeric? char-upper-case? + char-lower-case? char-upcase char-downcase + char->integer integer->char + string? string=? string>? string=? string<=? string-ci=? + string-ci? string-ci>=? string-ci<=? make-string + string-length string-ref string-set! string-append string-copy + string->list list->string substring string-fill! vector? make-vector + vector-ref vector-set! string vector vector-length vector->list + list->vector vector-fill! procedure? map for-each apply force + call-with-current-continuation input-port? output-port? + current-input-port current-output-port call-with-input-file + call-with-output-file open-input-file open-output-file + close-input-port close-output-port + read read-char peek-char write display write-char newline + eof-object? with-input-from-file with-output-to-file + char-ready? imag-part real-part make-rectangular make-polar angle + magnitude numerator denominator values call-with-values dynamic-wind + ;; NOTE: {null,scheme-report,interaction}-environment and eval + ;; are defined in chicken.eval, load is defined in chicken.load! + ;; The definition of "scheme" in modules.scm includes these. + ) + +;; We use r5rs-null to get just the syntax exports for "scheme", +;; because importing them from "scheme" would be importing then from +;; the module currently being defined, which is initially empty.... +(import r5rs-null) + +;;; Operations on booleans: + +(define (not x) (##core#inline "C_i_not" x)) +(define (boolean? x) (##core#inline "C_booleanp" x)) + + +;;; Equivalence predicates: + +(define (eq? x y) (##core#inline "C_eqp" x y)) +(define (eqv? x y) (##core#inline "C_i_eqvp" x y)) +(define (equal? x y) (##core#inline "C_i_equalp" x y)) + + +;;; Pairs and lists: + +(define (pair? x) (##core#inline "C_i_pairp" x)) +(define (cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y)) +(define (car x) (##core#inline "C_i_car" x)) +(define (cdr x) (##core#inline "C_i_cdr" x)) + +(define (set-car! x y) (##core#inline "C_i_set_car" x y)) +(define (set-cdr! x y) (##core#inline "C_i_set_cdr" x y)) +(define (cadr x) (##core#inline "C_i_cadr" x)) +(define (caddr x) (##core#inline "C_i_caddr" x)) +(define (cadddr x) (##core#inline "C_i_cadddr" x)) +(define (cddddr x) (##core#inline "C_i_cddddr" x)) + +(define (caar x) (##core#inline "C_i_caar" x)) +(define (cdar x) (##core#inline "C_i_cdar" x)) +(define (cddr x) (##core#inline "C_i_cddr" x)) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (##core#inline "C_i_cadr" x))) +(define (cadar x) (##core#inline "C_i_cadr" (car x))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (##core#inline "C_i_cadr" x))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (##core#inline "C_i_cadr" x)))) +(define (caadar x) (car (##core#inline "C_i_cadr" (car x)))) +(define (caaddr x) (car (##core#inline "C_i_caddr" x))) +(define (cadaar x) (##core#inline "C_i_cadr" (car (car x)))) +(define (cadadr x) (##core#inline "C_i_cadr" (##core#inline "C_i_cadr" x))) +(define (caddar x) (##core#inline "C_i_caddr" (car x))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (##core#inline "C_i_cadr" x)))) +(define (cdadar x) (cdr (##core#inline "C_i_cadr" (car x)))) +(define (cdaddr x) (cdr (##core#inline "C_i_caddr" x))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (##core#inline "C_i_cadr" x)))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) + +(define (null? x) (eq? x '())) +(define (list . lst) lst) +(define (length lst) (##core#inline "C_i_length" lst)) +(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i)) +(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i)) + +(define append) + +(define (reverse lst0) + (let loop ((lst lst0) (rest '())) + (cond ((eq? lst '()) rest) + ((pair? lst) + (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) ) + (else (##sys#error-not-a-proper-list lst0 'reverse)) ) )) + +(define (memq x lst) (##core#inline "C_i_memq" x lst)) +(define (memv x lst) (##core#inline "C_i_memv" x lst)) +(define (member x lst) (##core#inline "C_i_member" x lst)) +(define (assq x lst) (##core#inline "C_i_assq" x lst)) +(define (assv x lst) (##core#inline "C_i_assv" x lst)) +(define (assoc x lst) (##core#inline "C_i_assoc" x lst)) + +(define (list? x) (##core#inline "C_i_listp" x)) + +;;; Strings: + +(define make-string) + +(define (string? x) (##core#inline "C_i_stringp" x)) +(define (string-length s) (##core#inline "C_i_string_length" s)) +(define (string-ref s i) (##core#inline "C_i_string_ref" s i)) +(define (string-set! s i c) (##core#inline "C_i_string_set" s i c)) + +(define (string=? x y) + (##core#inline "C_i_string_equal_p" x y)) + +(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y)) + +(define string->list) +(define list->string) +(define string-fill) +(define string-copy) +(define substring) +(define string-fill!) + +(define string?) +(define string<=?) +(define string>=?) + +(define string-ci?) +(define string-ci<=?) +(define string-ci>=?) + +(define string) +(define string-append) + +;; Complex numbers +(define make-rectangular) +(define make-polar) +(define real-part) +(define imag-part) +(define angle) +(define magnitude) + +;; Rational numbers +(define numerator) +(define denominator) +(define inexact->exact) +(define (exact->inexact x) + (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) x)) + +;; Numerical operations +(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 7) x)) +(define + (##core#primitive "C_plus")) +(define - (##core#primitive "C_minus")) +(define * (##core#primitive "C_times")) +(define /) +(define floor) +(define ceiling) +(define truncate) +(define round) +(define rationalize) + +(define (quotient a b) (##core#inline_allocate ("C_s_a_i_quotient" 5) a b)) +(define (remainder a b) (##core#inline_allocate ("C_s_a_i_remainder" 5) a b)) +(define (modulo a b) (##core#inline_allocate ("C_s_a_i_modulo" 5) a b)) + +(define (even? n) (##core#inline "C_i_evenp" n)) +(define (odd? n) (##core#inline "C_i_oddp" n)) + +(define max) +(define min) +(define exp) +(define log) +(define sin) +(define cos) +(define tan) +(define asin) +(define acos) +(define atan) + +(define sqrt) +(define expt) +(define gcd) +(define lcm) + +(define = (##core#primitive "C_nequalp")) +(define > (##core#primitive "C_greaterp")) +(define < (##core#primitive "C_lessp")) +(define >= (##core#primitive "C_greater_or_equal_p")) +(define <= (##core#primitive "C_less_or_equal_p")) +(define (number? x) (##core#inline "C_i_numberp" x)) +(define complex? 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? x) (##core#inline "C_i_exactp" x)) +(define (inexact? x) (##core#inline "C_i_inexactp" x)) +(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 number->string (##core#primitive "C_number_to_string")) +(define string->number) + +;;; Symbols: + +(define (symbol? x) (##core#inline "C_i_symbolp" x)) +(define symbol->string) +(define string->symbol) + +;;; Vectors: + +(define (vector? x) (##core#inline "C_i_vectorp" x)) +(define (vector-length v) (##core#inline "C_i_vector_length" v)) +(define (vector-ref v i) (##core#inline "C_i_vector_ref" v i)) +(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x)) +(define make-vector) +(define list->vector) +(define vector->list) +(define vector) +(define vector-fill!) + +;;; Characters: + +(define (char? x) (##core#inline "C_charp" x)) +(define (char->integer c) + (##sys#check-char c 'char->integer) + (##core#inline "C_fix" (##core#inline "C_character_code" c)) ) + +(define (integer->char n) + (##sys#check-fixnum n 'integer->char) + (##core#inline "C_make_character" (##core#inline "C_unfix" n)) ) + +(define (char=? c1 c2) (##core#inline "C_i_char_equalp" c1 c2)) +(define (char>? c1 c2) (##core#inline "C_i_char_greaterp" c1 c2)) +(define (char=? c1 c2) (##core#inline "C_i_char_greater_or_equal_p" c1 c2)) +(define (char<=? c1 c2) (##core#inline "C_i_char_less_or_equal_p" c1 c2)) + +(define (char-upcase c) + (##sys#check-char c 'char-upcase) + (##core#inline "C_u_i_char_upcase" c)) + +(define (char-downcase c) + (##sys#check-char c 'char-downcase) + (##core#inline "C_u_i_char_downcase" c)) + +(define char-ci=?) +(define char-ci>?) +(define char-ci=?) +(define char-ci<=?) + +(define (char-upper-case? c) + (##sys#check-char c 'char-upper-case?) + (##core#inline "C_u_i_char_upper_casep" c) ) + +(define (char-lower-case? c) + (##sys#check-char c 'char-lower-case?) + (##core#inline "C_u_i_char_lower_casep" c) ) + +(define (char-numeric? c) + (##sys#check-char c 'char-numeric?) + (##core#inline "C_u_i_char_numericp" c) ) + +(define (char-whitespace? c) + (##sys#check-char c 'char-whitespace?) + (##core#inline "C_u_i_char_whitespacep" c) ) + +(define (char-alphabetic? c) + (##sys#check-char c 'char-alphabetic?) + (##core#inline "C_u_i_char_alphabeticp" c) ) + +;;; Procedures: + +(define (procedure? x) (##core#inline "C_i_closurep" x)) +(define apply (##core#primitive "C_apply")) +(define values (##core#primitive "C_values")) +(define call-with-values (##core#primitive "C_call_with_values")) +(define call-with-current-continuation) + +;;; Ports: + +(define (input-port? x) + (and (##core#inline "C_blockp" x) + (##core#inline "C_input_portp" x))) + +(define (output-port? x) + (and (##core#inline "C_blockp" x) + (##core#inline "C_output_portp" x))) + +(define current-input-port) +(define current-output-port) +(define open-input-file) +(define open-output-file) +(define close-input-port) +(define close-output-port) +(define call-with-input-file) +(define call-with-output-file) +(define with-input-from-file) +(define with-output-to-file) + +;;; Input: + +(define (eof-object? x) (##core#inline "C_eofp" x)) +(define char-ready?) +(define read-char) +(define peek-char) +(define read) + +;;; Output: + +(define write-char) +(define newline) +(define write) +(define display) + +;; Other stuff: + +(define force) +(define for-each) +(define map) +(define dynamic-wind) + +) ; scheme + +(import scheme) + +;; Pre-declaration of chicken.base, so it can be used later on. Much +;; like the "scheme" module, most declarations will be set! further +;; down in this file, mostly to avoid a cyclic dependency on itself. +;; The full definition (with macros) is in its own import library. (module chicken.base (;; [syntax] and-let* case-lambda cut cute declare define-constant ;; define-inline define-record define-record-type @@ -305,7 +685,7 @@ EOF ) ; chicken.base -(import (except chicken.base gensym add1 sub1)) ;;; see end of this file +(import chicken.base) (define-constant namespace-max-id-len 31) (define-constant char-name-table-size 37) @@ -317,7 +697,8 @@ EOF ;;; Fixnum arithmetic: (module chicken.fixnum * -(import chicken scheme chicken.foreign) +(import scheme) +(import chicken.foreign) (define most-positive-fixnum (foreign-value "C_MOST_POSITIVE_FIXNUM" int)) (define most-negative-fixnum (foreign-value "C_MOST_NEGATIVE_FIXNUM" int)) @@ -443,6 +824,7 @@ EOF (cpu-time current-milliseconds current-seconds) (import scheme) +(import (only (chicken module) reexport)) (reexport (only chicken time)) (define (current-milliseconds) @@ -452,13 +834,16 @@ EOF (##core#inline_allocate ("C_a_get_current_seconds" 7) #f)) (define cpu-time - (let ((buf (vector #f #f))) + (let () ;; ((buf (vector #f #f))) Disabled for now: vector is defined below! (lambda () - ;; should be thread-safe as no context-switch will occur after - ;; function entry and `buf' contents will have been extracted - ;; before `values' gets called. - (##core#inline_allocate ("C_a_i_cpu_time" 8) buf) - (values (##sys#slot buf 0) (##sys#slot buf 1)))))) + (let ((buf (vector #f #f))) + ;; should be thread-safe as no context-switch will occur after + ;; function entry and `buf' contents will have been extracted + ;; before `values' gets called. + (##core#inline_allocate ("C_a_i_cpu_time" 8) buf) + (values (##sys#slot buf 0) (##sys#slot buf 1)) )) )) + +) ; chicken.time (define (##sys#check-structure x y . loc) (if (pair? loc) @@ -565,31 +950,30 @@ EOF (##core#inline "C_i_check_closure_2" x (car loc)) (##core#inline "C_i_check_closure" x) ) ) -(define (force obj) - (if (##sys#structure? obj 'promise) - (let lp ((promise obj) - (forward #f)) - (let ((val (##sys#slot promise 1))) - (cond ((null? val) (##sys#values)) - ((pair? val) (apply ##sys#values val)) - ((procedure? val) - (when forward (##sys#setslot forward 1 promise)) - (let ((results (##sys#call-with-values val ##sys#list))) - (cond ((not (procedure? (##sys#slot promise 1))) - (lp promise forward)) ; in case of reentrance - ((and (not (null? results)) (null? (cdr results)) - (##sys#structure? (##sys#slot results 0) 'promise)) - (let ((result0 (##sys#slot results 0))) - (##sys#setslot promise 1 (##sys#slot result0 1)) - (lp promise result0))) - (else - (##sys#setslot promise 1 results) - (apply ##sys#values results))))) - ((##sys#structure? val 'promise) - (lp val forward))))) - obj)) - -(define ##sys#force force) +(set! scheme#force + (lambda (obj) + (if (##sys#structure? obj 'promise) + (let lp ((promise obj) + (forward #f)) + (let ((val (##sys#slot promise 1))) + (cond ((null? val) (##sys#values)) + ((pair? val) (apply ##sys#values val)) + ((procedure? val) + (when forward (##sys#setslot forward 1 promise)) + (let ((results (##sys#call-with-values val ##sys#list))) + (cond ((not (procedure? (##sys#slot promise 1))) + (lp promise forward)) ; in case of reentrance + ((and (not (null? results)) (null? (cdr results)) + (##sys#structure? (##sys#slot results 0) 'promise)) + (let ((result0 (##sys#slot results 0))) + (##sys#setslot promise 1 (##sys#slot result0 1)) + (lp promise result0))) + (else + (##sys#setslot promise 1 results) + (apply ##sys#values results))))) + ((##sys#structure? val 'promise) + (lp val forward))))) + obj))) (define (system cmd) (##sys#check-string cmd 'system) @@ -605,65 +989,6 @@ EOF (define ##sys#dload (##core#primitive "C_dload")) (define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags")) - -;;; Operations on booleans: - -(define (not x) (##core#inline "C_i_not" x)) -(define (boolean? x) (##core#inline "C_booleanp" x)) - - -;;; Equivalence predicates: - -(define (eq? x y) (##core#inline "C_eqp" x y)) -(define (eqv? x y) (##core#inline "C_i_eqvp" x y)) -(define (equal? x y) (##core#inline "C_i_equalp" x y)) - - -;;; Pairs and lists: - -(define (pair? x) (##core#inline "C_i_pairp" x)) -(define (cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y)) -(define (car x) (##core#inline "C_i_car" x)) -(define (cdr x) (##core#inline "C_i_cdr" x)) - -(define (set-car! x y) (##core#inline "C_i_set_car" x y)) -(define (set-cdr! x y) (##core#inline "C_i_set_cdr" x y)) -(define (cadr x) (##core#inline "C_i_cadr" x)) -(define (caddr x) (##core#inline "C_i_caddr" x)) -(define (cadddr x) (##core#inline "C_i_cadddr" x)) -(define (cddddr x) (##core#inline "C_i_cddddr" x)) - -(define (caar x) (##core#inline "C_i_caar" x)) -(define (cdar x) (##core#inline "C_i_cdar" x)) -(define (cddr x) (##core#inline "C_i_cddr" x)) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (##core#inline "C_i_cadr" x))) -(define (cadar x) (##core#inline "C_i_cadr" (car x))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (##core#inline "C_i_cadr" x))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) -(define (caaaar x) (car (car (car (car x))))) -(define (caaadr x) (car (car (##core#inline "C_i_cadr" x)))) -(define (caadar x) (car (##core#inline "C_i_cadr" (car x)))) -(define (caaddr x) (car (##core#inline "C_i_caddr" x))) -(define (cadaar x) (##core#inline "C_i_cadr" (car (car x)))) -(define (cadadr x) (##core#inline "C_i_cadr" (##core#inline "C_i_cadr" x))) -(define (caddar x) (##core#inline "C_i_caddr" (car x))) -(define (cdaaar x) (cdr (car (car (car x))))) -(define (cdaadr x) (cdr (car (##core#inline "C_i_cadr" x)))) -(define (cdadar x) (cdr (##core#inline "C_i_cadr" (car x)))) -(define (cdaddr x) (cdr (##core#inline "C_i_caddr" x))) -(define (cddaar x) (cdr (cdr (car (car x))))) -(define (cddadr x) (cdr (cdr (##core#inline "C_i_cadr" x)))) -(define (cdddar x) (cdr (cdr (cdr (car x))))) - -(define (null? x) (eq? x '())) -(define (list . lst) lst) -(define (length lst) (##core#inline "C_i_length" lst)) -(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i)) -(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i)) - (define (##sys#error-not-a-proper-list arg #!optional loc) (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) loc arg)) @@ -696,26 +1021,20 @@ EOF (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR" int) loc arg)) -(define (append . lsts) - (if (eq? lsts '()) - lsts - (let loop ((lsts lsts)) - (if (eq? (##sys#slot lsts 1) '()) - (##sys#slot lsts 0) - (let copy ((node (##sys#slot lsts 0))) - (cond ((eq? node '()) (loop (##sys#slot lsts 1))) - ((pair? node) - (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) - (else - (##sys#error-not-a-proper-list - (##sys#slot lsts 0) 'append)) ) ))))) - -(define (reverse lst0) - (let loop ((lst lst0) (rest '())) - (cond ((eq? lst '()) rest) - ((pair? lst) - (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) ) - (else (##sys#error-not-a-proper-list lst0 'reverse)) ) )) +(set! scheme#append + (lambda lsts + (if (eq? lsts '()) + lsts + (let loop ((lsts lsts)) + (if (eq? (##sys#slot lsts 1) '()) + (##sys#slot lsts 0) + (let copy ((node (##sys#slot lsts 0))) + (cond ((eq? node '()) (loop (##sys#slot lsts 1))) + ((pair? node) + (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) + (else + (##sys#error-not-a-proper-list + (##sys#slot lsts 0) 'append)) ) )))) ) ) (define (##sys#fast-reverse lst0) (let loop ((lst lst0) (rest '())) @@ -723,63 +1042,52 @@ EOF (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) rest))) -(define (memq x lst) (##core#inline "C_i_memq" x lst)) -(define (memv x lst) (##core#inline "C_i_memv" x lst)) -(define (member x lst) (##core#inline "C_i_member" x lst)) -(define (assq x lst) (##core#inline "C_i_assq" x lst)) -(define (assv x lst) (##core#inline "C_i_assv" x lst)) -(define (assoc x lst) (##core#inline "C_i_assoc" x lst)) - -(define (list? x) (##core#inline "C_i_listp" x)) - ;;; Strings: -(define (string? x) (##core#inline "C_i_stringp" x)) -(define (string-length s) (##core#inline "C_i_string_length" s)) -(define (string-ref s i) (##core#inline "C_i_string_ref" s i)) -(define (string-set! s i c) (##core#inline "C_i_string_set" s i c)) - (define-inline (%make-string size fill) (##sys#allocate-vector size #t fill #f) ) (define (##sys#make-string size #!optional (fill #\space)) (%make-string size fill)) -(define (make-string size . fill) - (##sys#check-fixnum size 'make-string) - (when (fx< size 0) - (##sys#signal-hook #:bounds-error 'make-string "size is negative" size)) - (%make-string - size - (if (null? fill) - #\space - (let ((c (car fill))) - (##sys#check-char c 'make-string) - c ) ) ) ) - -(define (string->list s) - (##sys#check-string s 'string->list) - (let ((len (##sys#size s))) - (let loop ((i (fx- len 1)) (ls '())) - (if (fx< i 0) - ls - (loop (fx- i 1) - (cons (##core#inline "C_subchar" s i) ls)))))) +(set! scheme#make-string + (lambda (size . fill) + (##sys#check-fixnum size 'make-string) + (when (fx< size 0) + (##sys#signal-hook #:bounds-error 'make-string "size is negative" size)) + (%make-string + size + (if (null? fill) + #\space + (let ((c (car fill))) + (##sys#check-char c 'make-string) + c ) ) ) ) ) + +(set! scheme#string->list + (lambda (s) + (##sys#check-string s 'string->list) + (let ((len (##sys#size s))) + (let loop ((i (fx- len 1)) (ls '())) + (if (fx< i 0) + ls + (loop (fx- i 1) + (cons (##core#inline "C_subchar" s i) ls)) ) ) ))) (define ##sys#string->list string->list) -(define (list->string lst0) - (if (not (list? lst0)) - (##sys#error-not-a-proper-list lst0 'list->string) - (let* ([len (length lst0)] - [s (##sys#make-string len)] ) - (do ([i 0 (fx+ i 1)] - [lst lst0 (##sys#slot lst 1)] ) - ((fx>= i len) s) - (let ([c (##sys#slot lst 0)]) - (##sys#check-char c 'list->string) - (##core#inline "C_setsubchar" s i c) ) ) ) )) +(set! scheme#list->string + (lambda (lst0) + (if (not (list? lst0)) + (##sys#error-not-a-proper-list lst0 'list->string) + (let* ([len (length lst0)] + [s (##sys#make-string len)] ) + (do ([i 0 (fx+ i 1)] + [lst lst0 (##sys#slot lst 1)] ) + ((fx>= i len) s) + (let ([c (##sys#slot lst 0)]) + (##sys#check-char c 'list->string) + (##core#inline "C_setsubchar" s i c) ) ) ) ))) (define ##sys#list->string list->string) @@ -798,13 +1106,14 @@ EOF s ) (##sys#error-not-a-proper-list l 'reverse-list->string) ) ) -(define (string-fill! s c) - (##sys#check-string s 'string-fill!) - (##sys#check-char c 'string-fill!) - (##core#inline "C_set_memory" s c (##sys#size s)) - (##core#undefined) ) +(set! scheme#string-fill! + (lambda (s c) + (##sys#check-string s 'string-fill!) + (##sys#check-char c 'string-fill!) + (##core#inline "C_set_memory" s c (##sys#size s)) + (##core#undefined) )) -(define string-copy +(set! scheme#string-copy (lambda (s) (##sys#check-string s 'string-copy) (let* ([len (##sys#size s)] @@ -812,34 +1121,30 @@ EOF (##core#inline "C_copy_memory" s2 s len) s2) ) ) -(define (substring s start . end) - (##sys#check-string s 'substring) - (##sys#check-fixnum start 'substring) - (let ([end (if (pair? end) - (let ([end (car end)]) - (##sys#check-fixnum end 'substring) - end) - (##sys#size s) ) ] ) - (let ([len (##sys#size s)]) - (if (and (fx<= start end) - (fx>= start 0) - (fx<= end len) ) - (##sys#substring s start end) - (##sys#error-hook - (foreign-value "C_OUT_OF_RANGE_ERROR" int) - 'substring start end) ) ) )) +(set! scheme#substring + (lambda (s start . end) + (##sys#check-string s 'substring) + (##sys#check-fixnum start 'substring) + (let ((end (if (pair? end) + (let ((end (car end))) + (##sys#check-fixnum end 'substring) + end) + (##sys#size s) ) ) ) + (let ((len (##sys#size s))) + (if (and (fx<= start end) + (fx>= start 0) + (fx<= end len) ) + (##sys#substring s start end) + (##sys#error-hook + (foreign-value "C_OUT_OF_RANGE_ERROR" int) + 'substring start end) ) ) ))) (define (##sys#substring s start end) (let ([s2 (##sys#make-string (fx- end start))]) (##core#inline "C_substring_copy" s s2 start end 0) s2 ) ) -(define (string=? x y) - (##core#inline "C_i_string_equal_p" x y)) - -(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y)) - -(letrec ((compare +(letrec ((compare (lambda (s1 s2 loc k) (##sys#check-string s1 loc) (##sys#check-string s2 loc) @@ -852,36 +1157,36 @@ EOF (if (fx< len1 len2) len1 len2) ) ) ) ) ) ) - (set! string? (lambda (s1 s2) - (compare - s1 s2 'string>? - (lambda (len1 len2 cmp) - (or (fx> cmp 0) - (and (fx< len2 len1) - (eq? cmp 0) ) ) ) ) ) ) - (set! string<=? (lambda (s1 s2) - (compare - s1 s2 'string<=? - (lambda (len1 len2 cmp) - (if (eq? cmp 0) - (fx<= len1 len2) - (fx< cmp 0) ) ) ) ) ) - (set! string>=? (lambda (s1 s2) - (compare - s1 s2 'string>=? - (lambda (len1 len2 cmp) - (if (eq? cmp 0) - (fx>= len1 len2) - (fx> cmp 0) ) ) ) ) ) ) - -(letrec ((compare + (set! scheme#string? (lambda (s1 s2) + (compare + s1 s2 'string>? + (lambda (len1 len2 cmp) + (or (fx> cmp 0) + (and (fx< len2 len1) + (eq? cmp 0) ) ) ) ) ) ) + (set! scheme#string<=? (lambda (s1 s2) + (compare + s1 s2 'string<=? + (lambda (len1 len2 cmp) + (if (eq? cmp 0) + (fx<= len1 len2) + (fx< cmp 0) ) ) ) ) ) + (set! scheme#string>=? (lambda (s1 s2) + (compare + s1 s2 'string>=? + (lambda (len1 len2 cmp) + (if (eq? cmp 0) + (fx>= len1 len2) + (fx> cmp 0) ) ) ) ) ) ) + +(letrec ((compare (lambda (s1 s2 loc k) (##sys#check-string s1 loc) (##sys#check-string s2 loc) @@ -894,34 +1199,34 @@ EOF (if (fx< len1 len2) len1 len2) ) ) ) ) ) ) - (set! string-ci? (lambda (s1 s2) - (compare - s1 s2 'string-ci>? - (lambda (len1 len2 cmp) - (or (fx> cmp 0) - (and (fx< len2 len1) - (eq? cmp 0) ) ) ) ) ) ) - (set! string-ci<=? (lambda (s1 s2) - (compare - s1 s2 'string-ci<=? - (lambda (len1 len2 cmp) - (if (eq? cmp 0) - (fx>= len1 len2) - (fx< cmp 0) ) ) ) ) ) - (set! string-ci>=? (lambda (s1 s2) - (compare - s1 s2 'string-ci>=? - (lambda (len1 len2 cmp) - (if (eq? cmp 0) - (fx<= len1 len2) - (fx> cmp 0) ) ) ) ) ) ) + (set! scheme#string-ci? (lambda (s1 s2) + (compare + s1 s2 'string-ci>? + (lambda (len1 len2 cmp) + (or (fx> cmp 0) + (and (fx< len2 len1) + (eq? cmp 0) ) ) ) ) ) ) + (set! scheme#string-ci<=? (lambda (s1 s2) + (compare + s1 s2 'string-ci<=? + (lambda (len1 len2 cmp) + (if (eq? cmp 0) + (fx>= len1 len2) + (fx< cmp 0) ) ) ) ) ) + (set! scheme#string-ci>=? (lambda (s1 s2) + (compare + s1 s2 'string-ci>=? + (lambda (len1 len2 cmp) + (if (eq? cmp 0) + (fx<= len1 len2) + (fx> cmp 0) ) ) ) ) ) ) (define (##sys#string-append x y) (let* ([s1 (##sys#size x)] @@ -931,19 +1236,20 @@ EOF (##core#inline "C_substring_copy" y z 0 s2 s1) z) ) -(define (string-append . all) - (let ([snew #f]) - (let loop ([strs all] [n 0]) - (if (eq? strs '()) - (set! snew (##sys#make-string n)) - (let ([s (##sys#slot strs 0)]) - (##sys#check-string s 'string-append) - (let ([len (##sys#size s)]) - (loop (##sys#slot strs 1) (fx+ n len)) - (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) ) - snew ) ) - -(define string +(set! scheme#string-append + (lambda all + (let ([snew #f]) + (let loop ([strs all] [n 0]) + (if (eq? strs '()) + (set! snew (##sys#make-string n)) + (let ([s (##sys#slot strs 0)]) + (##sys#check-string s 'string-append) + (let ([len (##sys#size s)]) + (loop (##sys#slot strs 1) (fx+ n len)) + (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) ) + snew ) )) + +(set! scheme#string (let ([list->string list->string]) (lambda chars (list->string chars)) ) ) @@ -965,7 +1271,12 @@ EOF ;; [MCA] Richard P. Brent & Paul Zimmermann, "Modern Computer Arithmetic" (module chicken.flonum * -(import chicken scheme chicken.foreign) +(import scheme) +(import chicken.foreign) +(import (only chicken.base flonum?)) +;; TODO: Importing these from chicken.base won't work due to +;; incomplete chicken.base definition above +(import (only chicken when unless define-inline)) (define maximum-flonum (foreign-value "DBL_MAX" double)) (define minimum-flonum (foreign-value "DBL_MIN" double)) @@ -1122,30 +1433,10 @@ EOF (define-inline (integer-negate x) (##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) x)) -(define = (##core#primitive "C_nequalp")) -(define > (##core#primitive "C_greaterp")) -(define < (##core#primitive "C_lessp")) -(define >= (##core#primitive "C_greater_or_equal_p")) -(define <= (##core#primitive "C_less_or_equal_p")) - -(define + (##core#primitive "C_plus")) -(define - (##core#primitive "C_minus")) -(define * (##core#primitive "C_times")) - -(define (number? x) (##core#inline "C_i_numberp" x)) (define ##sys#number? number?) -(define complex? 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 ##sys#integer? integer?) -(define (exact? x) (##core#inline "C_i_exactp" x)) -(define (inexact? x) (##core#inline "C_i_inexactp" x)) (define ##sys#exact? exact?) (define ##sys#inexact? inexact?) -(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)) ;;; Complex numbers @@ -1159,43 +1450,49 @@ EOF (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) - (##core#inline_allocate ("C_a_i_atan2" 4) - (exact->inexact (imag-part n)) - (exact->inexact (real-part n)))) - -(define (magnitude x) - (cond ((cplxnum? x) - (let ((r (%cplxnum-real x)) - (i (%cplxnum-imag x)) ) - (sqrt (+ (* r r) (* i i))) )) - ((number? x) (abs x)) - (else (##sys#error-bad-number x 'magnitude)))) +(set! scheme#make-rectangular + (lambda (r i) + (##sys#check-real r 'make-rectangular) + (##sys#check-real i 'make-rectangular) + (make-complex r i) )) + +(set! scheme#make-polar + (lambda (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))) ) )) + +(set! scheme#real-part + (lambda (x) + (cond ((cplxnum? x) (%cplxnum-real x)) + ((number? x) x) + (else (##sys#error-bad-number x 'real-part)) ))) + +(set! scheme#imag-part + (lambda (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)) ))) + +(set! scheme#angle + (lambda (n) + (##sys#check-number n 'angle) + (##core#inline_allocate ("C_a_i_atan2" 4) + (exact->inexact (imag-part n)) + (exact->inexact (real-part n))) )) + +(set! scheme#magnitude + (lambda (x) + (cond ((cplxnum? x) + (let ((r (%cplxnum-real x)) + (i (%cplxnum-imag x)) ) + (sqrt (+ (* r r) (* i i))) )) + ((number? x) (abs x)) + (else (##sys#error-bad-number x 'magnitude))) )) ;;; Rational numbers @@ -1211,27 +1508,29 @@ EOF (%make-ratnum (integer-negate m) (integer-negate n))) (else (%make-ratnum m n)))) -(define (numerator n) - (cond ((exact-integer? n) n) - ((##core#inline "C_i_flonump" n) - (cond ((not (finite? n)) (bad-inexact 'numerator n)) - ((##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)))) - -(define (denominator n) - (cond ((exact-integer? n) 1) - ((##core#inline "C_i_flonump" n) - (cond ((not (finite? n)) (bad-inexact 'denominator n)) - ((##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)))) +(set! scheme#numerator + (lambda (n) + (cond ((exact-integer? n) n) + ((##core#inline "C_i_flonump" n) + (cond ((not (finite? n)) (bad-inexact 'numerator n)) + ((##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)) (bad-inexact 'denominator n)) + ((##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 @@ -1264,19 +1563,17 @@ EOF (##sys#integer-power 2 flonum-precision)) (deliver x 1))) -(define (inexact->exact x) - (cond ((exact? x) x) - ((##core#inline "C_i_flonump" x) - (cond ((##core#inline "C_u_i_fpintegerp" x) (%flo->int x)) - ((##core#inline "C_u_i_flonum_finitep" x) (flonum->ratnum x)) - (else (##sys#error-bad-inexact x 'inexact->exact)))) - ((cplxnum? x) - (make-complex (inexact->exact (%cplxnum-real x)) - (inexact->exact (%cplxnum-imag x)))) - (else (##sys#error-bad-number x 'inexact->exact)))) - -(define (exact->inexact x) - (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) x)) +(set! scheme#inexact->exact + (lambda (x) + (cond ((exact? x) x) + ((##core#inline "C_i_flonump" x) + (cond ((##core#inline "C_u_i_fpintegerp" x) (%flo->int x)) + ((##core#inline "C_u_i_flonum_finitep" x) (flonum->ratnum x)) + (else (##sys#error-bad-inexact x 'inexact->exact)))) + ((cplxnum? x) + (make-complex (inexact->exact (%cplxnum-real x)) + (inexact->exact (%cplxnum-imag x)))) + (else (##sys#error-bad-number x 'inexact->exact)) ))) (define ##sys#exact->inexact exact->inexact) (define ##sys#inexact->exact inexact->exact) @@ -1297,7 +1594,9 @@ EOF ;; (define (bit-set? i n) (##core#inline "C_i_bit_setp" i n)) (define (integer-length x) (##core#inline "C_i_integer_length" x)) (define (arithmetic-shift n m) - (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 5) n m))) + (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 5) n m)) + +) ; chicken.bitwise (import chicken.bitwise) @@ -1306,17 +1605,16 @@ EOF (define-inline (%integer-gcd a b) (##core#inline_allocate ("C_s_a_u_i_integer_gcd" 5) a b)) -(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 7) x)) - -(define (/ arg1 . args) - (if (null? args) - (##sys#/-2 1 arg1) - (let loop ((args (##sys#slot args 1)) - (x (##sys#/-2 arg1 (##sys#slot args 0)))) - (if (null? args) - x - (loop (##sys#slot args 1) - (##sys#/-2 x (##sys#slot args 0))) ) ) ) ) +(set! scheme#/ + (lambda (arg1 . args) + (if (null? args) + (##sys#/-2 1 arg1) + (let loop ((args (##sys#slot args 1)) + (x (##sys#/-2 arg1 (##sys#slot args 0)))) + (if (null? args) + x + (loop (##sys#slot args 1) + (##sys#/-2 x (##sys#slot args 0))) ) ) ) )) (define-inline (%integer-quotient a b) (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) a b)) @@ -1373,41 +1671,45 @@ EOF ((not (number? x)) (##sys#error-bad-number x '/)) (else (##sys#error-bad-number y '/))) ) -(define (floor 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)))) - -(define (ceiling 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))) ) - -(define (truncate 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)))) - -(define (round 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)))) +(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)) ))) + +(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)) ))) + +(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)) ))) + +(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)) ))) (define (find-ratio-between x y) (define (sr x y) @@ -1429,49 +1731,46 @@ EOF (define (find-ratio x e) (find-ratio-between (- x e) (+ x e))) -(define (rationalize x e) - (let ((result (apply ##sys#/-2 (find-ratio x e)))) - (if (or (inexact? x) (inexact? e)) - (exact->inexact result) - result))) - -(define (quotient a b) (##core#inline_allocate ("C_s_a_i_quotient" 5) a b)) -(define (remainder a b) (##core#inline_allocate ("C_s_a_i_remainder" 5) a b)) -(define (modulo a b) (##core#inline_allocate ("C_s_a_i_modulo" 5) a b)) - -(define (even? n) (##core#inline "C_i_evenp" n)) -(define (odd? n) (##core#inline "C_i_oddp" n)) - -(define (max x1 . xs) - (let loop ((i (##core#inline "C_i_flonump" x1)) (m x1) (xs xs)) - (##sys#check-number m 'max) - (if (null? xs) - (if i (exact->inexact m) m) - (let ((h (##sys#slot xs 0))) - (loop (or i (##core#inline "C_i_flonump" h)) - (if (> h m) h m) - (##sys#slot xs 1)) ) ) ) ) - -(define (min x1 . xs) - (let loop ((i (##core#inline "C_i_flonump" x1)) (m x1) (xs xs)) - (##sys#check-number m 'min) - (if (null? xs) - (if i (exact->inexact m) m) - (let ((h (##sys#slot xs 0))) - (loop (or i (##core#inline "C_i_flonump" h)) - (if (< h m) h m) - (##sys#slot xs 1)) ) ) ) ) - -(define (exp n) - (##sys#check-number n 'exp) - (if (cplxnum? n) - (* (##core#inline_allocate ("C_a_i_exp" 4) - (exact->inexact (%cplxnum-real n))) - (let ((p (%cplxnum-imag n))) - (make-complex - (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact p)) - (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact p)) ) ) ) - (##core#inline_allocate ("C_a_i_flonum_exp" 4) (exact->inexact n)))) +(set! scheme#rationalize + (lambda (x e) + (let ((result (apply ##sys#/-2 (find-ratio x e)))) + (if (or (inexact? x) (inexact? e)) + (exact->inexact result) + result)) )) + +(set! scheme#max + (lambda (x1 . xs) + (let loop ((i (##core#inline "C_i_flonump" x1)) (m x1) (xs xs)) + (##sys#check-number m 'max) + (if (null? xs) + (if i (exact->inexact m) m) + (let ((h (##sys#slot xs 0))) + (loop (or i (##core#inline "C_i_flonump" h)) + (if (> h m) h m) + (##sys#slot xs 1)) ) ) ) )) + +(set! scheme#min + (lambda (x1 . xs) + (let loop ((i (##core#inline "C_i_flonump" x1)) (m x1) (xs xs)) + (##sys#check-number m 'min) + (if (null? xs) + (if i (exact->inexact m) m) + (let ((h (##sys#slot xs 0))) + (loop (or i (##core#inline "C_i_flonump" h)) + (if (< h m) h m) + (##sys#slot xs 1)) ) ) ) )) + +(set! scheme#exp + (lambda (n) + (##sys#check-number n 'exp) + (if (cplxnum? n) + (* (##core#inline_allocate ("C_a_i_exp" 4) + (exact->inexact (%cplxnum-real n))) + (let ((p (%cplxnum-imag n))) + (make-complex + (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact p)) + (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact p)) ) ) ) + (##core#inline_allocate ("C_a_i_flonum_exp" 4) (exact->inexact n)) ) )) (define (##sys#log-1 x) ; log_e(x) (cond @@ -1484,46 +1783,51 @@ EOF (else ; Real number case (< already ensured the argument type is a number) (##core#inline_allocate ("C_a_i_log" 4) (exact->inexact x))))) -(define (log a #!optional b) - (if b (##sys#/-2 (##sys#log-1 a) (##sys#log-1 b)) (##sys#log-1 a))) - -(define (sin n) - (##sys#check-number n 'sin) - (if (cplxnum? n) - (let ((in (* +i n))) - (##sys#/-2 (- (exp in) (exp (- in))) +2i)) - (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact n)))) - -(define (cos n) - (##sys#check-number n 'cos) - (if (cplxnum? n) - (let ((in (* +i n))) - (##sys#/-2 (+ (exp in) (exp (- in))) 2) ) - (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact n)))) - -(define (tan n) - (##sys#check-number n 'tan) - (if (cplxnum? n) - (##sys#/-2 (sin n) (cos n)) - (##core#inline_allocate ("C_a_i_tan" 4) (exact->inexact n)))) +(set! scheme#log + (lambda (a #!optional b) + (if b (##sys#/-2 (##sys#log-1 a) (##sys#log-1 b)) (##sys#log-1 a)))) + +(set! scheme#sin + (lambda (n) + (##sys#check-number n 'sin) + (if (cplxnum? n) + (let ((in (* +i n))) + (##sys#/-2 (- (exp in) (exp (- in))) +2i)) + (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact n)) ) )) + +(set! scheme#cos + (lambda (n) + (##sys#check-number n 'cos) + (if (cplxnum? n) + (let ((in (* +i n))) + (##sys#/-2 (+ (exp in) (exp (- in))) 2) ) + (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact n)) ) )) + +(set! scheme#tan + (lambda (n) + (##sys#check-number n 'tan) + (if (cplxnum? n) + (##sys#/-2 (sin n) (cos n)) + (##core#inline_allocate ("C_a_i_tan" 4) (exact->inexact n)) ) )) ;; General case: sin^{-1}(z) = -i\ln(iz + \sqrt{1-z^2}) -(define (asin n) - (##sys#check-number n 'asin) - (cond ((and (##core#inline "C_i_flonump" n) (fp>= n -1.0) (fp<= n 1.0)) - (##core#inline_allocate ("C_a_i_asin" 4) n)) - ((and (##core#inline "C_fixnump" n) (fx>= n -1) (fx<= n 1)) - (##core#inline_allocate ("C_a_i_asin" 4) - (##core#inline_allocate - ("C_a_i_fix_to_flo" 4) n))) - ;; General definition can return compnums - (else (* -i (##sys#log-1 - (+ (* +i n) - (##sys#sqrt/loc 'asin (- 1 (* n n))))))))) +(set! scheme#asin + (lambda (n) + (##sys#check-number n 'asin) + (cond ((and (##core#inline "C_i_flonump" n) (fp>= n -1.0) (fp<= n 1.0)) + (##core#inline_allocate ("C_a_i_asin" 4) n)) + ((and (##core#inline "C_fixnump" n) (fx>= n -1) (fx<= n 1)) + (##core#inline_allocate ("C_a_i_asin" 4) + (##core#inline_allocate + ("C_a_i_fix_to_flo" 4) n))) + ;; General definition can return compnums + (else (* -i (##sys#log-1 + (+ (* +i n) + (##sys#sqrt/loc 'asin (- 1 (* n n))))) )) ) )) ;; General case: ;; cos^{-1}(z) = 1/2\pi + i\ln(iz + \sqrt{1-z^2}) = 1/2\pi - sin^{-1}(z) = sin(1) - sin(z) -(define acos +(set! scheme#acos (let ((asin1 (##core#inline_allocate ("C_a_i_asin" 4) 1))) (lambda (n) (##sys#check-number n 'acos) @@ -1536,20 +1840,21 @@ EOF ;; General definition can return compnums (else (- asin1 (asin n))))))) -(define (atan n #!optional b) - (##sys#check-number n 'atan) - (cond ((cplxnum? n) - (if b - (##sys#error-bad-real n 'atan) - (let ((in (* +i n))) - (##sys#/-2 (- (##sys#log-1 (+ 1 in)) - (##sys#log-1 (- 1 in))) +2i)))) - (b - (##core#inline_allocate - ("C_a_i_atan2" 4) (exact->inexact n) (exact->inexact b))) - (else - (##core#inline_allocate - ("C_a_i_atan" 4) (exact->inexact n))))) +(set! scheme#atan + (lambda (n #!optional b) + (##sys#check-number n 'atan) + (cond ((cplxnum? n) + (if b + (##sys#error-bad-real n 'atan) + (let ((in (* +i n))) + (##sys#/-2 (- (##sys#log-1 (+ 1 in)) + (##sys#log-1 (- 1 in))) +2i)))) + (b + (##core#inline_allocate + ("C_a_i_atan2" 4) (exact->inexact n) (exact->inexact b))) + (else + (##core#inline_allocate + ("C_a_i_atan" 4) (exact->inexact n))) ) )) ;; This is "Karatsuba Square Root" as described by Paul Zimmermann, ;; which is 3/2K(n) + O(n log n) for an input of 2n words, where K(n) @@ -1612,7 +1917,7 @@ EOF (##sys#sqrt/loc loc (exact->inexact n))))) (else (##core#inline_allocate ("C_a_i_sqrt" 4) (exact->inexact n))))) -(define (sqrt x) (##sys#sqrt/loc 'sqrt x)) +(set! scheme#sqrt (lambda (x) (##sys#sqrt/loc 'sqrt x))) (set! chicken.base#exact-integer-nth-root (lambda (k n) @@ -1656,54 +1961,55 @@ EOF (else (lp (* res base) (- e2 1))))))) -(define (expt a b) - (define (log-expt a b) - (exp (* b (##sys#log-1 a)))) - (define (slow-expt a b) - (if (eq? 0 a) - (##sys#signal-hook - #:arithmetic-error 'expt - "exponent of exact 0 with complex argument is undefined" a b) - (exp (* b (##sys#log-1 a))))) - (cond ((not (number? a)) (##sys#error-bad-number a 'expt)) - ((not (number? b)) (##sys#error-bad-number b 'expt)) - ((and (ratnum? a) (not (inexact? b))) - ;; (n*d)^b = n^b * d^b = n^b * x^{-b} | x = 1/b - ;; Hopefully faster than integer-power - (* (expt (%ratnum-numerator a) b) - (expt (%ratnum-denominator a) (- b)))) - ((ratnum? b) - ;; x^{a/b} = (x^{1/b})^a - (cond - ((exact-integer? a) - (if (negative? a) - (log-expt (exact->inexact a) (exact->inexact b)) - (receive (ds^n r) - (##sys#exact-integer-nth-root/loc - 'expt a (%ratnum-denominator b)) - (if (eq? r 0) - (##sys#integer-power ds^n (%ratnum-numerator b)) - (##core#inline_allocate ("C_a_i_flonum_expt" 4) - (exact->inexact a) - (exact->inexact b)))))) - ((##core#inline "C_i_flonump" a) - (log-expt a (exact->inexact b))) - (else (slow-expt a b)))) - ((or (cplxnum? b) (and (cplxnum? a) (not (integer? b)))) - (slow-expt a b)) - ((and (##core#inline "C_i_flonump" b) - (not (##core#inline "C_u_i_fpintegerp" b))) - (if (negative? a) - (log-expt (exact->inexact a) (exact->inexact b)) - (##core#inline_allocate - ("C_a_i_flonum_expt" 4) (exact->inexact a) b))) - ((##core#inline "C_i_flonump" a) - (##core#inline_allocate ("C_a_i_flonum_expt" 4) a (exact->inexact b))) - ;; this doesn't work that well, yet... - ;; (XXX: What does this mean? why not? I do know this is ugly... :P) - (else (if (or (inexact? a) (inexact? b)) - (exact->inexact (##sys#integer-power a (inexact->exact b))) - (##sys#integer-power a b)))) ) +(set! scheme#expt + (lambda (a b) + (define (log-expt a b) + (exp (* b (##sys#log-1 a)))) + (define (slow-expt a b) + (if (eq? 0 a) + (##sys#signal-hook + #:arithmetic-error 'expt + "exponent of exact 0 with complex argument is undefined" a b) + (exp (* b (##sys#log-1 a))))) + (cond ((not (number? a)) (##sys#error-bad-number a 'expt)) + ((not (number? b)) (##sys#error-bad-number b 'expt)) + ((and (ratnum? a) (not (inexact? b))) + ;; (n*d)^b = n^b * d^b = n^b * x^{-b} | x = 1/b + ;; Hopefully faster than integer-power + (* (expt (%ratnum-numerator a) b) + (expt (%ratnum-denominator a) (- b)))) + ((ratnum? b) + ;; x^{a/b} = (x^{1/b})^a + (cond + ((exact-integer? a) + (if (negative? a) + (log-expt (exact->inexact a) (exact->inexact b)) + (receive (ds^n r) + (##sys#exact-integer-nth-root/loc + 'expt a (%ratnum-denominator b)) + (if (eq? r 0) + (##sys#integer-power ds^n (%ratnum-numerator b)) + (##core#inline_allocate ("C_a_i_flonum_expt" 4) + (exact->inexact a) + (exact->inexact b)))))) + ((##core#inline "C_i_flonump" a) + (log-expt a (exact->inexact b))) + (else (slow-expt a b)))) + ((or (cplxnum? b) (and (cplxnum? a) (not (integer? b)))) + (slow-expt a b)) + ((and (##core#inline "C_i_flonump" b) + (not (##core#inline "C_u_i_fpintegerp" b))) + (if (negative? a) + (log-expt (exact->inexact a) (exact->inexact b)) + (##core#inline_allocate + ("C_a_i_flonum_expt" 4) (exact->inexact a) b))) + ((##core#inline "C_i_flonump" a) + (##core#inline_allocate ("C_a_i_flonum_expt" 4) a (exact->inexact b))) + ;; this doesn't work that well, yet... + ;; (XXX: What does this mean? why not? I do know this is ugly... :P) + (else (if (or (inexact? a) (inexact? b)) + (exact->inexact (##sys#integer-power a (inexact->exact b))) + (##sys#integer-power a b)))) )) ;; Useful for sane error messages (define (##sys#internal-gcd loc a b) @@ -1724,32 +2030,34 @@ EOF ;; For compat reasons, we define this (define (##sys#gcd a b) (##sys#internal-gcd 'gcd a b)) -(define (gcd . ns) - (if (eq? ns '()) - 0 - (let loop ((head (##sys#slot ns 0)) - (next (##sys#slot ns 1))) - (if (null? next) - (if (integer? head) (abs head) (##sys#error-bad-integer head 'gcd)) - (let ((n2 (##sys#slot next 0))) - (loop (##sys#internal-gcd 'gcd head n2) - (##sys#slot next 1)) ) ) ) ) ) +(set! scheme#gcd + (lambda ns + (if (eq? ns '()) + 0 + (let loop ((head (##sys#slot ns 0)) + (next (##sys#slot ns 1))) + (if (null? next) + (if (integer? head) (abs head) (##sys#error-bad-integer head 'gcd)) + (let ((n2 (##sys#slot next 0))) + (loop (##sys#internal-gcd 'gcd head n2) + (##sys#slot next 1)) ) ) ) ) )) (define (##sys#lcm x y) (let ((gcd (##sys#internal-gcd 'lcm x y))) ; Ensure better error message (abs (quotient (* x y) gcd) ) ) ) -(define (lcm . ns) - (if (null? ns) - 1 - (let loop ((head (##sys#slot ns 0)) - (next (##sys#slot ns 1))) - (if (null? next) - (if (integer? head) (abs head) (##sys#error-bad-integer head 'lcm)) - (let* ((n2 (##sys#slot next 0)) - (gcd (##sys#internal-gcd 'lcm head n2))) - (loop (quotient (* head n2) gcd) - (##sys#slot next 1)) ) ) ) ) ) +(set! scheme#lcm + (lambda ns + (if (null? ns) + 1 + (let loop ((head (##sys#slot ns 0)) + (next (##sys#slot ns 1))) + (if (null? next) + (if (integer? head) (abs head) (##sys#error-bad-integer head 'lcm)) + (let* ((n2 (##sys#slot next 0)) + (gcd (##sys#internal-gcd 'lcm head n2))) + (loop (quotient (* head n2) gcd) + (##sys#slot next 1)) ) ) ) ) )) ;; This simple enough idea is from ;; http://www.numberworld.org/y-cruncher/internals/radix-conversion.html @@ -1784,7 +2092,6 @@ EOF (number->string i base) "i") )) (else (##sys#error-bad-number n 'number->string))) ) ) ) -(define number->string (##core#primitive "C_number_to_string")) (define ##sys#number->string number->string) ; for printer ;; We try to prevent memory exhaustion attacks by limiting the @@ -2024,76 +2331,76 @@ EOF ;; Ensure we didn't encounter +inf.0 or +nan.0 with #e (and (finite? number) number))))) -(define (string->number str #!optional (base 10)) - (##sys#check-string str 'string->number) - (unless (and (##core#inline "C_fixnump" base) - (fx< 1 base) (fx< base 37)) ; We only have 0-9 and the alphabet! - (##sys#error-bad-base base 'string->number)) - (let scan-prefix ((i 0) - (exness #f) - (radix #f) - (len (##sys#size str))) - (if (and (fx< (fx+ i 2) len) (eq? (%subchar str i) #\#)) - (case (%subchar str (fx+ i 1)) - ((#\i #\I) (and (not exness) (scan-prefix (fx+ i 2) 'i radix len))) - ((#\e #\E) (and (not exness) (scan-prefix (fx+ i 2) 'e radix len))) - ((#\b #\B) (and (not radix) (scan-prefix (fx+ i 2) exness 2 len))) - ((#\o #\O) (and (not radix) (scan-prefix (fx+ i 2) exness 8 len))) - ((#\d #\D) (and (not radix) (scan-prefix (fx+ i 2) exness 10 len))) - ((#\x #\X) (and (not radix) (scan-prefix (fx+ i 2) exness 16 len))) - (else #f)) - (##sys#string->compnum (or radix base) str i exness)))) +(set! scheme#string->number + (lambda (str #!optional (base 10)) + (##sys#check-string str 'string->number) + (unless (and (##core#inline "C_fixnump" base) + (fx< 1 base) (fx< base 37)) ; We only have 0-9 and the alphabet! + (##sys#error-bad-base base 'string->number)) + (let scan-prefix ((i 0) + (exness #f) + (radix #f) + (len (##sys#size str))) + (if (and (fx< (fx+ i 2) len) (eq? (%subchar str i) #\#)) + (case (%subchar str (fx+ i 1)) + ((#\i #\I) (and (not exness) (scan-prefix (fx+ i 2) 'i radix len))) + ((#\e #\E) (and (not exness) (scan-prefix (fx+ i 2) 'e radix len))) + ((#\b #\B) (and (not radix) (scan-prefix (fx+ i 2) exness 2 len))) + ((#\o #\O) (and (not radix) (scan-prefix (fx+ i 2) exness 8 len))) + ((#\d #\D) (and (not radix) (scan-prefix (fx+ i 2) exness 10 len))) + ((#\x #\X) (and (not radix) (scan-prefix (fx+ i 2) exness 16 len))) + (else #f)) + (##sys#string->compnum (or radix base) str i exness))))) (define (##sys#string->number str #!optional (radix 10) exactness) (##sys#string->compnum radix str 0 exactness)) -(define number->string (##core#primitive "C_number_to_string")) (define ##sys#fixnum->string (##core#primitive "C_fixnum_to_string")) (define ##sys#flonum->string (##core#primitive "C_flonum_to_string")) (define ##sys#integer->string (##core#primitive "C_integer_to_string")) (define ##sys#number->string number->string) -(define (equal=? x y) - (define (compare-slots x y start) - (let ((l1 (##sys#size x)) - (l2 (##sys#size y))) - (and (eq? l1 l2) - (or (fx<= l1 start) - (let ((l1n (fx- l1 1))) - (let loop ((i start)) - (if (fx= i l1n) - (walk (##sys#slot x i) (##sys#slot y i)) ; tailcall - (and (walk (##sys#slot x i) (##sys#slot y i)) - (loop (fx+ i 1)))))))))) - (define (walk x y) - (cond ((eq? x y)) - ((number? x) - (if (number? y) - (= x y) - (eq? x y))) - ((not (##core#inline "C_blockp" x)) #f) - ((not (##core#inline "C_blockp" y)) #f) - ((not (##core#inline "C_sametypep" x y)) #f) - ((##core#inline "C_specialp" x) - (and (##core#inline "C_specialp" y) - (if (##core#inline "C_closurep" x) - (##core#inline "shallow_equal" x y) - (compare-slots x y 1)))) - ((##core#inline "C_byteblockp" x) - (and (##core#inline "C_byteblockp" y) - (let ((s1 (##sys#size x))) - (and (eq? s1 (##sys#size y)) - (##core#inline "C_substring_compare" x y 0 0 s1))))) - (else - (let ((s1 (##sys#size x))) - (and (eq? s1 (##sys#size y)) - (compare-slots x y 0)))))) - (walk x y)) +(set! chicken.base#equal=? + (lambda (x y) + (define (compare-slots x y start) + (let ((l1 (##sys#size x)) + (l2 (##sys#size y))) + (and (eq? l1 l2) + (or (fx<= l1 start) + (let ((l1n (fx- l1 1))) + (let loop ((i start)) + (if (fx= i l1n) + (walk (##sys#slot x i) (##sys#slot y i)) ; tailcall + (and (walk (##sys#slot x i) (##sys#slot y i)) + (loop (fx+ i 1)))))))))) + (define (walk x y) + (cond ((eq? x y)) + ((number? x) + (if (number? y) + (= x y) + (eq? x y))) + ((not (##core#inline "C_blockp" x)) #f) + ((not (##core#inline "C_blockp" y)) #f) + ((not (##core#inline "C_sametypep" x y)) #f) + ((##core#inline "C_specialp" x) + (and (##core#inline "C_specialp" y) + (if (##core#inline "C_closurep" x) + (##core#inline "shallow_equal" x y) + (compare-slots x y 1)))) + ((##core#inline "C_byteblockp" x) + (and (##core#inline "C_byteblockp" y) + (let ((s1 (##sys#size x))) + (and (eq? s1 (##sys#size y)) + (##core#inline "C_substring_compare" x y 0 0 s1))))) + (else + (let ((s1 (##sys#size x))) + (and (eq? s1 (##sys#size y)) + (compare-slots x y 0)))))) + (walk x y) )) ;;; Symbols: -(define (symbol? x) (##core#inline "C_i_symbolp" x)) (define ##sys#snafu '##sys#fnord) (define ##sys#intern-symbol (##core#primitive "C_string_to_symbol")) (define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x)) @@ -2150,12 +2457,13 @@ EOF (##sys#string-append prefix str) str) ) ) ) -(define (symbol->string s) - (##sys#check-symbol s 'symbol->string) - (string-copy (##sys#symbol->string s) ) ) +(set! scheme#symbol->string + (lambda (s) + (##sys#check-symbol s 'symbol->string) + (string-copy (##sys#symbol->string s) ) )) -(define string->symbol - (let ([string-copy string-copy]) +(set! scheme#string->symbol + (let ((string-copy string-copy)) (lambda (str) (##sys#check-string str 'string->symbol) (##sys#intern-symbol (string-copy str)) ) ) ) @@ -2199,7 +2507,8 @@ EOF (module chicken.keyword (keyword? get-keyword keyword->string string->keyword) -(import scheme chicken chicken.fixnum) +(import scheme) +(import chicken.fixnum) (define (keyword? x) (and (symbol? x) (##core#inline "C_u_i_keywordp" x)) ) @@ -2236,7 +2545,7 @@ EOF (module chicken.blob (blob->string string->blob blob? blob=? blob-size make-blob) -(import scheme chicken) +(import scheme) (define (##sys#make-blob size) (let ([bv (##sys#allocate-vector size #t #f #t)]) @@ -2279,56 +2588,54 @@ EOF ) ; chicken.blob + ;;; Vectors: +(set! scheme#make-vector + (lambda (size . fill) + (##sys#check-fixnum size 'make-vector) + (when (fx< size 0) (##sys#error 'make-vector "size is negative" size)) + (##sys#allocate-vector + size #f + (if (null? fill) + (##core#undefined) + (car fill) ) + #f) )) -(define (vector? x) (##core#inline "C_i_vectorp" x)) -(define (vector-length v) (##core#inline "C_i_vector_length" v)) -(define (vector-ref v i) (##core#inline "C_i_vector_ref" v i)) -(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x)) +(define ##sys#make-vector make-vector) -(define (make-vector size . fill) - (##sys#check-fixnum size 'make-vector) - (when (fx< size 0) (##sys#error 'make-vector "size is negative" size)) - (##sys#allocate-vector - size #f - (if (null? fill) - (##core#undefined) - (car fill) ) - #f) ) +(set! scheme#list->vector + (lambda (lst0) + (if (not (list? lst0)) + (##sys#error-not-a-proper-list lst0 'list->vector) + (let* ([len (length lst0)] + [v (##sys#make-vector len)] ) + (let loop ([lst lst0] + [i 0]) + (if (null? lst) + v + (begin + (##sys#setslot v i (##sys#slot lst 0)) + (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) ))) -(define ##sys#make-vector make-vector) +(set! scheme#vector->list + (lambda (v) + (##sys#check-vector v 'vector->list) + (let ((len (##core#inline "C_block_size" v))) + (let loop ((i 0)) + (if (fx>= i len) + '() + (cons (##sys#slot v i) + (loop (fx+ i 1)) ) ) ) ) )) -(define (list->vector lst0) - (if (not (list? lst0)) - (##sys#error-not-a-proper-list lst0 'list->vector) - (let* ([len (length lst0)] - [v (##sys#make-vector len)] ) - (let loop ([lst lst0] - [i 0]) - (if (null? lst) - v - (begin - (##sys#setslot v i (##sys#slot lst 0)) - (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )) - -(define (vector->list v) - (##sys#check-vector v 'vector->list) - (let ((len (##core#inline "C_block_size" v))) - (let loop ((i 0)) - (if (fx>= i len) - '() - (cons (##sys#slot v i) - (loop (fx+ i 1)) ) ) ) ) ) - -(define (vector . xs) - (##sys#list->vector xs) ) - -(define (vector-fill! v x) - (##sys#check-vector v 'vector-fill!) - (let ((len (##core#inline "C_block_size" v))) - (do ((i 0 (fx+ i 1))) - ((fx>= i len)) - (##sys#setslot v i x) ) ) ) +(set! scheme#vector (lambda xs (list->vector xs) )) + +(set! scheme#vector-fill! + (lambda (v x) + (##sys#check-vector v 'vector-fill!) + (let ((len (##core#inline "C_block_size" v))) + (do ((i 0 (fx+ i 1))) + ((fx>= i len)) + (##sys#setslot v i x) ) ) )) (set! chicken.base#vector-copy! (lambda (from to . n) @@ -2374,70 +2681,26 @@ EOF ;;; Characters: -(define (char? x) (##core#inline "C_charp" x)) - -(define (char->integer c) - (##sys#check-char c 'char->integer) - (##core#inline "C_fix" (##core#inline "C_character_code" c)) ) - -(define (integer->char n) - (##sys#check-fixnum n 'integer->char) - (##core#inline "C_make_character" (##core#inline "C_unfix" n)) ) - -(define (char=? c1 c2) (##core#inline "C_i_char_equalp" c1 c2)) -(define (char>? c1 c2) (##core#inline "C_i_char_greaterp" c1 c2)) -(define (char=? c1 c2) (##core#inline "C_i_char_greater_or_equal_p" c1 c2)) -(define (char<=? c1 c2) (##core#inline "C_i_char_less_or_equal_p" c1 c2)) - -(define (char-upcase c) - (##sys#check-char c 'char-upcase) - (##core#inline "C_u_i_char_upcase" c)) - -(define (char-downcase c) - (##sys#check-char c 'char-downcase) - (##core#inline "C_u_i_char_downcase" c)) - -(define char-ci=?) -(define char-ci>?) -(define char-ci=?) -(define char-ci<=?) - (let ((char-downcase char-downcase)) - (set! char-ci=? (lambda (x y) (eq? (char-downcase x) (char-downcase y)))) - (set! char-ci>? (lambda (x y) - (##core#inline "C_u_i_char_greaterp" - (char-downcase x) (char-downcase y)))) - (set! char-ci=? (lambda (x y) - (##core#inline "C_u_i_char_greater_or_equal_p" - (char-downcase x) (char-downcase y)))) - (set! char-ci<=? (lambda (x y) - (##core#inline "C_u_i_char_less_or_equal_p" - (char-downcase x) (char-downcase y)))) ) - -(define (char-upper-case? c) - (##sys#check-char c 'char-upper-case?) - (##core#inline "C_u_i_char_upper_casep" c) ) - -(define (char-lower-case? c) - (##sys#check-char c 'char-lower-case?) - (##core#inline "C_u_i_char_lower_casep" c) ) - -(define (char-numeric? c) - (##sys#check-char c 'char-numeric?) - (##core#inline "C_u_i_char_numericp" c) ) - -(define (char-whitespace? c) - (##sys#check-char c 'char-whitespace?) - (##core#inline "C_u_i_char_whitespacep" c) ) - -(define (char-alphabetic? c) - (##sys#check-char c 'char-alphabetic?) - (##core#inline "C_u_i_char_alphabeticp" c) ) + (set! scheme#char-ci=? (lambda (x y) + (eq? (char-downcase x) + (char-downcase y)))) + (set! scheme#char-ci>? (lambda (x y) + (##core#inline "C_u_i_char_greaterp" + (char-downcase x) + (char-downcase y)))) + (set! scheme#char-ci=? (lambda (x y) + (##core#inline "C_u_i_char_greater_or_equal_p" + (char-downcase x) + (char-downcase y)))) + (set! scheme#char-ci<=? (lambda (x y) + (##core#inline "C_u_i_char_less_or_equal_p" + (char-downcase x) + (char-downcase y)))) ) (set! chicken.base#char-name (let ((chars-to-names (make-vector char-name-table-size '())) @@ -2498,12 +2761,8 @@ EOF ;;; Procedures: -(define (procedure? x) (##core#inline "C_i_closurep" x)) -(define apply (##core#primitive "C_apply")) (define ##sys#call-with-current-continuation (##core#primitive "C_call_cc")) (define ##sys#call-with-cthulhu (##core#primitive "C_call_with_cthulhu")) -(define values (##core#primitive "C_values")) -(define call-with-values (##core#primitive "C_call_with_values")) (define ##sys#call-with-values call-with-values) (define (##sys#for-each p lst0) @@ -2521,9 +2780,6 @@ EOF (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) ) (else (##sys#error-not-a-proper-list lst0 'map)) ) )) -(define for-each) -(define map) - (letrec ((mapsafe (lambda (p lsts start loc) (if (eq? lsts '()) @@ -2543,7 +2799,7 @@ EOF (loop (##sys#slot lsts 1)) ) ) ) (##sys#error loc "lists are not of same length" lsts) ) ) ) ) - (set! for-each + (set! scheme#for-each (lambda (fn lst1 . lsts) (if (null? lsts) (##sys#for-each fn lst1) @@ -2554,7 +2810,7 @@ EOF (loop (mapsafe (lambda (x) (cdr x)) all #t 'for-each)) ) (else (check all #t 'for-each)) ) ) ) ) ) ) - (set! map + (set! scheme#map (lambda (fn lst1 . lsts) (if (null? lsts) (##sys#map fn lst1) @@ -2581,27 +2837,29 @@ EOF (define ##sys#dynamic-winds '()) -(define (dynamic-wind before thunk after) - (before) - (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds)) - (##sys#call-with-values - thunk - (lambda results - (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1)) - (after) - (apply ##sys#values results) ) ) ) +(set! scheme#dynamic-wind + (lambda (before thunk after) + (before) + (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds)) + (##sys#call-with-values + thunk + (lambda results + (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1)) + (after) + (apply ##sys#values results) ) ) )) (define ##sys#dynamic-wind dynamic-wind) -(define (call-with-current-continuation proc) - (let ((winds ##sys#dynamic-winds)) - (##sys#call-with-current-continuation - (lambda (cont) - (define (continuation . results) - (unless (eq? ##sys#dynamic-winds winds) - (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) ) - (apply cont results) ) - (proc continuation))))) +(set! scheme#call-with-current-continuation + (lambda (proc) + (let ((winds ##sys#dynamic-winds)) + (##sys#call-with-current-continuation + (lambda (cont) + (define (continuation . results) + (unless (eq? ##sys#dynamic-winds winds) + (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) ) + (apply cont results) ) + (proc continuation) ))) )) (set! chicken.base#call/cc call-with-current-continuation) @@ -2624,14 +2882,6 @@ EOF (and (##core#inline "C_blockp" x) (##core#inline "C_portp" x))) -(define (input-port? x) - (and (##core#inline "C_blockp" x) - (##core#inline "C_input_portp" x))) - -(define (output-port? x) - (and (##core#inline "C_blockp" x) - (##core#inline "C_output_portp" x))) - (define (input-port-open? p) (##sys#check-input-port p 'input-port-open?) (##core#inline "C_input_port_openp" p)) @@ -2642,8 +2892,7 @@ EOF (define (port-closed? p) (##sys#check-port p 'port-closed?) - (fx= (##sys#slot p 8) 0)) - + (eq? (##sys#slot p 8) 0)) ;;; Port layout: ; @@ -2817,23 +3066,25 @@ EOF (##core#inline "C_i_check_port_2" x 0 #t (car loc)) (##core#inline "C_i_check_port" x 0 #t) ) ) -(define (current-input-port . args) - (if (null? args) - ##sys#standard-input - (let ((p (car args))) - (##sys#check-port p 'current-input-port) - (let-optionals (cdr args) ((convert? #t) (set? #t)) - (when set? (set! ##sys#standard-input p))) - p))) +(set! scheme#current-input-port + (lambda args + (if (null? args) + ##sys#standard-input + (let ((p (car args))) + (##sys#check-port p 'current-input-port) + (let-optionals (cdr args) ((convert? #t) (set? #t)) + (when set? (set! ##sys#standard-input p))) + p) ) )) -(define (current-output-port . args) - (if (null? args) - ##sys#standard-output - (let ((p (car args))) - (##sys#check-port p 'current-output-port) - (let-optionals (cdr args) ((convert? #t) (set? #t)) - (when set? (set! ##sys#standard-output p))) - p))) +(set! scheme#current-output-port + (lambda args + (if (null? args) + ##sys#standard-output + (let ((p (car args))) + (##sys#check-port p 'current-output-port) + (let-optionals (cdr args) ((convert? #t) (set? #t)) + (when set? (set! ##sys#standard-output p))) + p) ) )) (set! chicken.base#current-error-port (lambda args @@ -2852,11 +3103,6 @@ EOF (define (##sys#port-data port) (##sys#slot port 9)) (define (##sys#set-port-data! port data) (##sys#setslot port 9 data)) -(define open-input-file) -(define open-output-file) -(define close-input-port) -(define close-output-port) - (let () (define (open name inp modes loc) (##sys#check-string name loc) @@ -2887,34 +3133,34 @@ EOF (##sys#setislot port 8 (fxand (##sys#slot port 8) (fxnot direction))) ((##sys#slot (##sys#slot port 2) 4) port direction)))) - (set! open-input-file (lambda (name . mode) (open name #t mode 'open-input-file))) - (set! open-output-file (lambda (name . mode) (open name #f mode 'open-output-file))) - (set! close-input-port (lambda (port) (close port #t 'close-input-port))) - (set! close-output-port (lambda (port) (close port #f 'close-output-port)))) + (set! scheme#open-input-file (lambda (name . mode) (open name #t mode 'open-input-file))) + (set! scheme#open-output-file (lambda (name . mode) (open name #f mode 'open-output-file))) + (set! scheme#close-input-port (lambda (port) (close port #t 'close-input-port))) + (set! scheme#close-output-port (lambda (port) (close port #f 'close-output-port)))) -(define call-with-input-file - (let ([open-input-file open-input-file] - [close-input-port close-input-port] ) +(set! scheme#call-with-input-file + (let ((open-input-file open-input-file) + (close-input-port close-input-port) ) (lambda (name p . mode) - (let ([f (apply open-input-file name mode)]) + (let ((f (apply open-input-file name mode))) (##sys#call-with-values (lambda () (p f)) (lambda results (close-input-port f) (apply ##sys#values results) ) ) ) ) ) ) -(define call-with-output-file - (let ([open-output-file open-output-file] - [close-output-port close-output-port] ) +(set! scheme#call-with-output-file + (let ((open-output-file open-output-file) + (close-output-port close-output-port) ) (lambda (name p . mode) - (let ([f (apply open-output-file name mode)]) + (let ((f (apply open-output-file name mode))) (##sys#call-with-values (lambda () (p f)) (lambda results (close-output-port f) (apply ##sys#values results) ) ) ) ) ) ) -(define with-input-from-file +(set! scheme#with-input-from-file (let ((open-input-file open-input-file) (close-input-port close-input-port) ) (lambda (str thunk . mode) @@ -2925,7 +3171,7 @@ EOF (close-input-port file) (apply ##sys#values results) ) ) ) ) ) ) ) -(define with-output-to-file +(set! scheme#with-output-to-file (let ((open-output-file open-output-file) (close-output-port close-output-port) ) (lambda (str thunk . mode) @@ -3098,26 +3344,26 @@ EOF p)) p1)))) -(set! car (getter-with-setter car set-car! "(car p)")) -(set! cdr (getter-with-setter cdr set-cdr! "(cdr p)")) -(set! caar (getter-with-setter caar (lambda (x y) (set-car! (car x) y)) "(caar p)")) -(set! cadr (getter-with-setter cadr (lambda (x y) (set-car! (cdr x) y)) "(cadr p)")) -(set! cdar (getter-with-setter cdar (lambda (x y) (set-cdr! (car x) y)) "(cdar p)")) -(set! cddr (getter-with-setter cddr (lambda (x y) (set-cdr! (cdr x) y)) "(cddr p)")) -(set! caaar (getter-with-setter caaar (lambda (x y) (set-car! (caar x) y)) "(caaar p)")) -(set! caadr (getter-with-setter caadr (lambda (x y) (set-car! (cadr x) y)) "(caadr p)")) -(set! cadar (getter-with-setter cadar (lambda (x y) (set-car! (cdar x) y)) "(cadar p)")) -(set! caddr (getter-with-setter caddr (lambda (x y) (set-car! (cddr x) y)) "(caddr p)")) -(set! cdaar (getter-with-setter cdaar (lambda (x y) (set-cdr! (caar x) y)) "(cdaar p)")) -(set! cdadr (getter-with-setter cdadr (lambda (x y) (set-cdr! (cadr x) y)) "(cdadr p)")) -(set! cddar (getter-with-setter cddar (lambda (x y) (set-cdr! (cdar x) y)) "(cddar p)")) -(set! cdddr (getter-with-setter cdddr (lambda (x y) (set-cdr! (cddr x) y)) "(cdddr p)")) -(set! string-ref (getter-with-setter string-ref string-set! "(string-ref str i)")) -(set! vector-ref (getter-with-setter vector-ref vector-set! "(vector-ref vec i)")) - -(set! list-ref +(set! scheme#car (getter-with-setter scheme#car set-car! "(car p)")) +(set! scheme#cdr (getter-with-setter scheme#cdr set-cdr! "(cdr p)")) +(set! scheme#caar (getter-with-setter scheme#caar (lambda (x y) (set-car! (car x) y)) "(caar p)")) +(set! scheme#cadr (getter-with-setter scheme#cadr (lambda (x y) (set-car! (cdr x) y)) "(cadr p)")) +(set! scheme#cdar (getter-with-setter scheme#cdar (lambda (x y) (set-cdr! (car x) y)) "(cdar p)")) +(set! scheme#cddr (getter-with-setter scheme#cddr (lambda (x y) (set-cdr! (cdr x) y)) "(cddr p)")) +(set! scheme#caaar (getter-with-setter scheme#caaar (lambda (x y) (set-car! (caar x) y)) "(caaar p)")) +(set! scheme#caadr (getter-with-setter scheme#caadr (lambda (x y) (set-car! (cadr x) y)) "(caadr p)")) +(set! scheme#cadar (getter-with-setter scheme#cadar (lambda (x y) (set-car! (cdar x) y)) "(cadar p)")) +(set! scheme#caddr (getter-with-setter scheme#caddr (lambda (x y) (set-car! (cddr x) y)) "(caddr p)")) +(set! scheme#cdaar (getter-with-setter scheme#cdaar (lambda (x y) (set-cdr! (caar x) y)) "(cdaar p)")) +(set! scheme#cdadr (getter-with-setter scheme#cdadr (lambda (x y) (set-cdr! (cadr x) y)) "(cdadr p)")) +(set! scheme#cddar (getter-with-setter scheme#cddar (lambda (x y) (set-cdr! (cdar x) y)) "(cddar p)")) +(set! scheme#cdddr (getter-with-setter scheme#cdddr (lambda (x y) (set-cdr! (cddr x) y)) "(cdddr p)")) +(set! scheme#string-ref (getter-with-setter scheme#string-ref string-set! "(string-ref str i)")) +(set! scheme#vector-ref (getter-with-setter scheme#vector-ref vector-set! "(vector-ref vec i)")) + +(set! scheme#list-ref (getter-with-setter - list-ref + scheme#list-ref (lambda (x i y) (set-car! (list-tail x i) y)) "(list-ref lst i)")) @@ -3174,15 +3420,15 @@ EOF ;;; Input: -(define (eof-object? x) (##core#inline "C_eofp" x)) - -(define (char-ready? #!optional (port ##sys#standard-input)) - (##sys#check-input-port port #t 'char-ready?) - ((##sys#slot (##sys#slot port 2) 6) port) ) ; char-ready? +(set! scheme#char-ready? + (lambda (#!optional (port ##sys#standard-input)) + (##sys#check-input-port port #t 'char-ready?) + ((##sys#slot (##sys#slot port 2) 6) port) )) ; char-ready? -(define (read-char #!optional (port ##sys#standard-input)) - (##sys#check-input-port port #t 'read-char) - (##sys#read-char-0 port)) +(set! scheme#read-char + (lambda (#!optional (port ##sys#standard-input)) + (##sys#check-input-port port #t 'read-char) + (##sys#read-char-0 port) )) (define (##sys#read-char-0 p) (let ([c (if (##sys#slot p 6) @@ -3209,13 +3455,15 @@ EOF (##sys#setislot p 6 #t) ) c) ) ) -(define (peek-char #!optional (port ##sys#standard-input)) - (##sys#check-input-port port #t 'peek-char) - (##sys#peek-char-0 port) ) +(set! scheme#peek-char + (lambda (#!optional (port ##sys#standard-input)) + (##sys#check-input-port port #t 'peek-char) + (##sys#peek-char-0 port) )) -(define (read #!optional (port ##sys#standard-input)) - (##sys#check-input-port port #t 'read) - (##sys#read port ##sys#default-read-info-hook) ) +(set! read + (lambda (#!optional (port ##sys#standard-input)) + (##sys#check-input-port port #t 'read) + (##sys#read port ##sys#default-read-info-hook) )) (define ##sys#default-read-info-hook #f) (define ##sys#read-error-with-line-number #f) @@ -3941,21 +4189,25 @@ EOF (##sys#check-char c 'write-char) (##sys#write-char-0 c port) ) -(define (write-char c #!optional (port ##sys#standard-output)) - (##sys#check-char c 'write-char) - (##sys#check-output-port port #t 'write-char) - (##sys#write-char-0 c port) ) +(set! scheme#write-char + (lambda (c #!optional (port ##sys#standard-output)) + (##sys#check-char c 'write-char) + (##sys#check-output-port port #t 'write-char) + (##sys#write-char-0 c port) )) -(define (newline #!optional (port ##sys#standard-output)) - (##sys#write-char/port #\newline port) ) +(set! scheme#newline + (lambda (#!optional (port ##sys#standard-output)) + (##sys#write-char/port #\newline port) )) -(define (write x #!optional (port ##sys#standard-output)) - (##sys#check-output-port port #t 'write) - (##sys#print x #t port) ) +(set! scheme#write + (lambda (x #!optional (port ##sys#standard-output)) + (##sys#check-output-port port #t 'write) + (##sys#print x #t port) )) -(define (display x #!optional (port ##sys#standard-output)) - (##sys#check-output-port port #t 'display) - (##sys#print x #f port) ) +(set! scheme#display + (lambda (x #!optional (port ##sys#standard-output)) + (##sys#check-output-port port #t 'display) + (##sys#print x #f port) )) (define-inline (*print-each lst) (for-each (cut ##sys#print <> #f ##sys#standard-output) lst) ) @@ -3967,7 +4219,7 @@ EOF (##sys#write-char-0 #\newline ##sys#standard-output) (void))) -(define print* +(set! chicken.base#print* (lambda args (##sys#check-output-port ##sys#standard-output #t 'print) (*print-each args) @@ -5441,7 +5693,9 @@ EOF (module chicken.gc (current-gc-milliseconds gc memory-statistics set-finalizer! set-gc-report!) -(import scheme chicken chicken.fixnum chicken.foreign) +(import scheme) +(import chicken.fixnum chicken.foreign) +(import (only chicken when unless handle-exceptions)) ;;; GC info: @@ -5574,7 +5828,6 @@ EOF (define ##sys#null? null?) (define ##sys#map-n map) - ;;; We need this here so `location' works: (define (##sys#make-locative obj index weak? loc) @@ -5651,7 +5904,9 @@ EOF (module chicken.plist (get get-properties put! remprop! symbol-plist) -(import scheme chicken) +(import scheme) +(import (only (chicken base) getter-with-setter)) +(import (only chicken when)) (define (put! sym prop val) (##sys#check-symbol sym 'put!) @@ -5782,7 +6037,10 @@ EOF software-type software-version ) -(import scheme chicken chicken.fixnum chicken.foreign chicken.keyword) +(import scheme) +(import chicken.fixnum chicken.foreign chicken.keyword) +(import (only chicken get-environment-variable make-parameter)) +(import (only chicken when unless define-constant)) (define software-type (let ((sym (string->symbol ((##core#primitive "C_software_type"))))) @@ -5942,3 +6200,203 @@ EOF (loop (##sys#slot ids 1)))))) ) ; chicken.platform + + + +;;; OBSOLETE: Remove after bootstrapping. This ensures the unprefixed +;;; names are still bound to the correct definitions, because "scheme" +;;; in the bootstrapping compiler's modules.scm may still refer to +;;; them by the unprefixed name. +(##sys#setslot 'not 0 scheme#not) +(##sys#setslot 'boolean? 0 scheme#boolean?) +(##sys#setslot 'eq? 0 scheme#eq?) +(##sys#setslot 'eqv? 0 scheme#eqv?) +(##sys#setslot 'equal? 0 scheme#equal?) +(##sys#setslot 'pair? 0 scheme#pair?) +(##sys#setslot 'cons 0 scheme#cons) +(##sys#setslot 'car 0 scheme#car) +(##sys#setslot 'cdr 0 scheme#cdr) +(##sys#setslot 'caar 0 scheme#caar) +(##sys#setslot 'cadr 0 scheme#cadr) +(##sys#setslot 'cdar 0 scheme#cdar) +(##sys#setslot 'cddr 0 scheme#cddr) +(##sys#setslot 'caaar 0 scheme#caaar) +(##sys#setslot 'caadr 0 scheme#caadr) +(##sys#setslot 'cadar 0 scheme#cadar) +(##sys#setslot 'caddr 0 scheme#caddr) +(##sys#setslot 'cdaar 0 scheme#cdaar) +(##sys#setslot 'cdadr 0 scheme#cdadr) +(##sys#setslot 'cddar 0 scheme#cddar) +(##sys#setslot 'cdddr 0 scheme#cdddr) +(##sys#setslot 'caaaar 0 scheme#caaaar) +(##sys#setslot 'caaadr 0 scheme#caaadr) +(##sys#setslot 'caadar 0 scheme#caadar) +(##sys#setslot 'caaddr 0 scheme#caaddr) +(##sys#setslot 'cadaar 0 scheme#cadaar) +(##sys#setslot 'cadadr 0 scheme#cadadr) +(##sys#setslot 'caddar 0 scheme#caddar) +(##sys#setslot 'cadddr 0 scheme#cadddr) +(##sys#setslot 'cdaaar 0 scheme#cdaaar) +(##sys#setslot 'cdaadr 0 scheme#cdaadr) +(##sys#setslot 'cdadar 0 scheme#cdadar) +(##sys#setslot 'cdaddr 0 scheme#cdaddr) +(##sys#setslot 'cddaar 0 scheme#cddaar) +(##sys#setslot 'cddadr 0 scheme#cddadr) +(##sys#setslot 'cdddar 0 scheme#cdddar) +(##sys#setslot 'cddddr 0 scheme#cddddr) +(##sys#setslot 'set-car! 0 scheme#set-car!) +(##sys#setslot 'set-cdr! 0 scheme#set-cdr!) +(##sys#setslot 'null? 0 scheme#null?) +(##sys#setslot 'list? 0 scheme#list?) +(##sys#setslot 'list 0 scheme#list) +(##sys#setslot 'length 0 scheme#length) +(##sys#setslot 'list-tail 0 scheme#list-tail) +(##sys#setslot 'list-ref 0 scheme#list-ref) +(##sys#setslot 'append 0 scheme#append) +(##sys#setslot 'reverse 0 scheme#reverse) +(##sys#setslot 'memq 0 scheme#memq) +(##sys#setslot 'memv 0 scheme#memv) +(##sys#setslot 'member 0 scheme#member) +(##sys#setslot 'assq 0 scheme#assq) +(##sys#setslot 'assv 0 scheme#assv) +(##sys#setslot 'assoc 0 scheme#assoc) +(##sys#setslot 'symbol? 0 scheme#symbol?) +(##sys#setslot 'symbol->string 0 scheme#symbol->string) +(##sys#setslot 'string->symbol 0 scheme#string->symbol) +(##sys#setslot 'number? 0 scheme#number?) +(##sys#setslot 'integer? 0 scheme#integer?) +(##sys#setslot 'exact? 0 scheme#exact?) +(##sys#setslot 'real? 0 scheme#real?) +(##sys#setslot 'complex? 0 scheme#complex?) +(##sys#setslot 'inexact? 0 scheme#inexact?) +(##sys#setslot 'rational? 0 scheme#rational?) +(##sys#setslot 'zero? 0 scheme#zero?) +(##sys#setslot 'odd? 0 scheme#odd?) +(##sys#setslot 'even? 0 scheme#even?) +(##sys#setslot 'positive? 0 scheme#positive?) +(##sys#setslot 'negative? 0 scheme#negative?) +(##sys#setslot 'max 0 scheme#max) +(##sys#setslot 'min 0 scheme#min) +(##sys#setslot '+ 0 scheme#+) +(##sys#setslot '- 0 scheme#-) +(##sys#setslot '* 0 scheme#*) +(##sys#setslot '/ 0 scheme#/) +(##sys#setslot '= 0 scheme#=) +(##sys#setslot '> 0 scheme#>) +(##sys#setslot '< 0 scheme#<) +(##sys#setslot '>= 0 scheme#>=) +(##sys#setslot '<= 0 scheme#<=) +(##sys#setslot 'quotient 0 scheme#quotient) +(##sys#setslot 'remainder 0 scheme#remainder) +(##sys#setslot 'modulo 0 scheme#modulo) +(##sys#setslot 'gcd 0 scheme#gcd) +(##sys#setslot 'lcm 0 scheme#lcm) +(##sys#setslot 'abs 0 scheme#abs) +(##sys#setslot 'floor 0 scheme#floor) +(##sys#setslot 'ceiling 0 scheme#ceiling) +(##sys#setslot 'truncate 0 scheme#truncate) +(##sys#setslot 'round 0 scheme#round) +(##sys#setslot 'rationalize 0 scheme#rationalize) +(##sys#setslot 'exact->inexact 0 scheme#exact->inexact) +(##sys#setslot 'inexact->exact 0 scheme#inexact->exact) +(##sys#setslot 'exp 0 scheme#exp) +(##sys#setslot 'log 0 scheme#log) +(##sys#setslot 'expt 0 scheme#expt) +(##sys#setslot 'sqrt 0 scheme#sqrt) +(##sys#setslot 'sin 0 scheme#sin) +(##sys#setslot 'cos 0 scheme#cos) +(##sys#setslot 'tan 0 scheme#tan) +(##sys#setslot 'asin 0 scheme#asin) +(##sys#setslot 'acos 0 scheme#acos) +(##sys#setslot 'atan 0 scheme#atan) +(##sys#setslot 'number->string 0 scheme#number->string) +(##sys#setslot 'string->number 0 scheme#string->number) +(##sys#setslot 'char? 0 scheme#char?) +(##sys#setslot 'char=? 0 scheme#char=?) +(##sys#setslot 'char>? 0 scheme#char>?) +(##sys#setslot 'char=? 0 scheme#char>=?) +(##sys#setslot 'char<=? 0 scheme#char<=?) +(##sys#setslot 'char-ci=? 0 scheme#char-ci=?) +(##sys#setslot 'char-ci? 0 scheme#char-ci>?) +(##sys#setslot 'char-ci>=? 0 scheme#char-ci>=?) +(##sys#setslot 'char-ci<=? 0 scheme#char-ci<=?) +(##sys#setslot 'char-alphabetic? 0 scheme#char-alphabetic?) +(##sys#setslot 'char-whitespace? 0 scheme#char-whitespace?) +(##sys#setslot 'char-numeric? 0 scheme#char-numeric?) +(##sys#setslot 'char-upper-case? 0 scheme#char-upper-case?) +(##sys#setslot 'char-lower-case? 0 scheme#char-lower-case?) +(##sys#setslot 'char-upcase 0 scheme#char-upcase) +(##sys#setslot 'char-downcase 0 scheme#char-downcase) +(##sys#setslot 'char->integer 0 scheme#char->integer) +(##sys#setslot 'integer->char 0 scheme#integer->char) +(##sys#setslot 'string? 0 scheme#string?) +(##sys#setslot 'string=? 0 scheme#string=?) +(##sys#setslot 'string>? 0 scheme#string>?) +(##sys#setslot 'string=? 0 scheme#string>=?) +(##sys#setslot 'string<=? 0 scheme#string<=?) +(##sys#setslot 'string-ci=? 0 scheme#string-ci=?) +(##sys#setslot 'string-ci? 0 scheme#string-ci>?) +(##sys#setslot 'string-ci>=? 0 scheme#string-ci>=?) +(##sys#setslot 'string-ci<=? 0 scheme#string-ci<=?) +(##sys#setslot 'make-string 0 scheme#make-string) +(##sys#setslot 'string-length 0 scheme#string-length) +(##sys#setslot 'string-ref 0 scheme#string-ref) +(##sys#setslot 'string-set! 0 scheme#string-set!) +(##sys#setslot 'string-append 0 scheme#string-append) +(##sys#setslot 'string-copy 0 scheme#string-copy) +(##sys#setslot 'string->list 0 scheme#string->list) +(##sys#setslot 'list->string 0 scheme#list->string) +(##sys#setslot 'substring 0 scheme#substring) +(##sys#setslot 'string-fill! 0 scheme#string-fill!) +(##sys#setslot 'vector? 0 scheme#vector?) +(##sys#setslot 'make-vector 0 scheme#make-vector) +(##sys#setslot 'vector-ref 0 scheme#vector-ref) +(##sys#setslot 'vector-set! 0 scheme#vector-set!) +(##sys#setslot 'string 0 scheme#string) +(##sys#setslot 'vector 0 scheme#vector) +(##sys#setslot 'vector-length 0 scheme#vector-length) +(##sys#setslot 'vector->list 0 scheme#vector->list) +(##sys#setslot 'list->vector 0 scheme#list->vector) +(##sys#setslot 'vector-fill! 0 scheme#vector-fill!) +(##sys#setslot 'procedure? 0 scheme#procedure?) +(##sys#setslot 'map 0 scheme#map) +(##sys#setslot 'for-each 0 scheme#for-each) +(##sys#setslot 'apply 0 scheme#apply) +(##sys#setslot 'force 0 scheme#force) +(##sys#setslot 'call-with-current-continuation 0 scheme#call-with-current-continuation) +(##sys#setslot 'input-port? 0 scheme#input-port?) +(##sys#setslot 'output-port? 0 scheme#output-port?) +(##sys#setslot 'current-input-port 0 scheme#current-input-port) +(##sys#setslot 'current-output-port 0 scheme#current-output-port) +(##sys#setslot 'call-with-input-file 0 scheme#call-with-input-file) +(##sys#setslot 'call-with-output-file 0 scheme#call-with-output-file) +(##sys#setslot 'open-input-file 0 scheme#open-input-file) +(##sys#setslot 'open-output-file 0 scheme#open-output-file) +(##sys#setslot 'close-input-port 0 scheme#close-input-port) +(##sys#setslot 'close-output-port 0 scheme#close-output-port) +(##sys#setslot 'read 0 scheme#read) +(##sys#setslot 'read-char 0 scheme#read-char) +(##sys#setslot 'peek-char 0 scheme#peek-char) +(##sys#setslot 'write 0 scheme#write) +(##sys#setslot 'display 0 scheme#display) +(##sys#setslot 'write-char 0 scheme#write-char) +(##sys#setslot 'newline 0 scheme#newline) +(##sys#setslot 'eof-object? 0 scheme#eof-object?) +(##sys#setslot 'with-input-from-file 0 scheme#with-input-from-file) +(##sys#setslot 'with-output-to-file 0 scheme#with-output-to-file) +(##sys#setslot 'char-ready? 0 scheme#char-ready?) +(##sys#setslot 'imag-part 0 scheme#imag-part) +(##sys#setslot 'real-part 0 scheme#real-part) +(##sys#setslot 'make-rectangular 0 scheme#make-rectangular) +(##sys#setslot 'make-polar 0 scheme#make-polar) +(##sys#setslot 'angle 0 scheme#angle) +(##sys#setslot 'magnitude 0 scheme#magnitude) +(##sys#setslot 'numerator 0 scheme#numerator) +(##sys#setslot 'denominator 0 scheme#denominator) +(##sys#setslot 'dynamic-wind 0 scheme#dynamic-wind) +(##sys#setslot 'values 0 scheme#values) +(##sys#setslot 'call-with-values 0 scheme#call-with-values) diff --git a/modules.scm b/modules.scm index 8d99a0f4..148e8f55 100644 --- a/modules.scm +++ b/modules.scm @@ -322,24 +322,24 @@ (##sys#register-compiled-module ',(module-name mod) ',(module-library mod) - (list + (scheme#list ,@(map (lambda (ie) (if (symbol? (cdr ie)) `'(,(car ie) . ,(cdr ie)) - `(list ',(car ie) '() ,(cdr ie)))) + `(scheme#list ',(car ie) '() ,(cdr ie)))) (module-iexports mod))) ',(module-vexports mod) - (list + (scheme#list ,@(map (lambda (sexport) (let* ((name (car sexport)) (a (assq name dlist))) (cond ((pair? a) - `(cons ',(car sexport) ,(strip-syntax (cdr a)))) + `(scheme#cons ',(car sexport) ,(strip-syntax (cdr a)))) (else (dm "re-exported syntax" name mname) `',name)))) sexports)) - (list + (scheme#list ,@(if (null? sexports) '() ; no syntax exported - no more info needed (let loop ((sd (module-defined-syntax-list mod))) @@ -347,7 +347,7 @@ ((assq (caar sd) sexports) (loop (cdr sd))) (else (let ((name (caar sd))) - (cons `(cons ',(caar sd) ,(strip-syntax (cdar sd))) + (cons `(scheme#cons ',(caar sd) ,(strip-syntax (cdar sd))) (loop (cdr sd))))))))))))) (define (##sys#register-compiled-module name lib iexports vexports sexports #!optional @@ -902,39 +902,131 @@ ;;; built-in modules (needed for eval environments) (let ((r4rs-values - '(not boolean? eq? eqv? equal? pair? - cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr - cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar - cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr! - null? list? list length list-tail list-ref append reverse memq memv - 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 - modulo gcd lcm abs floor ceiling truncate round rationalize - exact->inexact inexact->exact exp log expt sqrt - sin cos tan asin acos atan - number->string string->number char? char=? char>? char=? - char<=? char-ci=? char-ci? char-ci>=? char-ci<=? - char-alphabetic? char-whitespace? char-numeric? char-upper-case? - char-lower-case? char-upcase char-downcase char->integer integer->char - string? string=? string>? string=? string<=? string-ci=? - string-ci? string-ci>=? string-ci<=? make-string - string-length string-ref string-set! string-append string-copy - string->list list->string substring string-fill! vector? make-vector - vector-ref vector-set! string vector vector-length vector->list - list->vector vector-fill! procedure? map for-each apply force - call-with-current-continuation input-port? output-port? - current-input-port current-output-port call-with-input-file - call-with-output-file open-input-file open-output-file - close-input-port close-output-port (load . chicken.load#load) - read read-char peek-char write display write-char newline eof-object? - with-input-from-file with-output-to-file (eval . chicken.eval#eval) - char-ready? imag-part real-part make-rectangular make-polar angle - magnitude numerator denominator - (scheme-report-environment . chicken.eval#scheme-report-environment) - (null-environment . chicken.eval#null-environment) - (interaction-environment . chicken.eval#interaction-environment) - else)) + '((not . scheme#not) (boolean? . scheme#boolean?) + (eq? . scheme#eq?) (eqv? . scheme#eqv?) (equal? . scheme#equal?) + (pair? . scheme#pair?) (cons . scheme#cons) + (car . scheme#car) (cdr . scheme#cdr) + (caar . scheme#caar) (cadr . scheme#cadr) (cdar . scheme#cdar) + (cddr . scheme#cddr) + (caaar . scheme#caaar) (caadr . scheme#caadr) + (cadar . scheme#cadar) (caddr . scheme#caddr) + (cdaar . scheme#cdaar) (cdadr . scheme#cdadr) + (cddar . scheme#cddar) (cdddr . scheme#cdddr) + (caaaar . scheme#caaaar) (caaadr . scheme#caaadr) + (caadar . scheme#caadar) (caaddr . scheme#caaddr) + (cadaar . scheme#cadaar) (cadadr . scheme#cadadr) + (caddar . scheme#caddar) (cadddr . scheme#cadddr) + (cdaaar . scheme#cdaaar) (cdaadr . scheme#cdaadr) + (cdadar . scheme#cdadar) (cdaddr . scheme#cdaddr) + (cddaar . scheme#cddaar) (cddadr . scheme#cddadr) + (cdddar . scheme#cdddar) (cddddr . scheme#cddddr) + (set-car! . scheme#set-car!) (set-cdr! . scheme#set-cdr!) + (null? . scheme#null?) (list? . scheme#list?) + (list . scheme#list) (length . scheme#length) + (list-tail . scheme#list-tail) (list-ref . scheme#list-ref) + (append . scheme#append) (reverse . scheme#reverse) + (memq . scheme#memq) (memv . scheme#memv) + (member . scheme#member) (assq . scheme#assq) + (assv . scheme#assv) (assoc . scheme#assoc) + (symbol? . scheme#symbol?) + (symbol->string . scheme#symbol->string) + (string->symbol . scheme#string->symbol) + (number? . scheme#number?) (integer? . scheme#integer?) + (exact? . scheme#exact?) (real? . scheme#real?) + (complex? . scheme#complex?) (inexact? . scheme#inexact?) + (rational? . scheme#rational?) (zero? . scheme#zero?) + (odd? . scheme#odd?) (even? . scheme#even?) + (positive? . scheme#positive?) (negative? . scheme#negative?) + (max . scheme#max) (min . scheme#min) + (+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/) + (= . scheme#=) (> . scheme#>) (< . scheme#<) + (>= . scheme#>=) (<= . scheme#<=) + (quotient . scheme#quotient) (remainder . scheme#remainder) + (modulo . scheme#modulo) + (gcd . scheme#gcd) (lcm . scheme#lcm) (abs . scheme#abs) + (floor . scheme#floor) (ceiling . scheme#ceiling) + (truncate . scheme#truncate) (round . scheme#round) + (rationalize . scheme#rationalize) + (exact->inexact . scheme#exact->inexact) + (inexact->exact . scheme#inexact->exact) + (exp . scheme#exp) (log . scheme#log) (expt . scheme#expt) + (sqrt . scheme#sqrt) + (sin . scheme#sin) (cos . scheme#cos) (tan . scheme#tan) + (asin . scheme#asin) (acos . scheme#acos) (atan . scheme#atan) + (number->string . scheme#number->string) + (string->number . scheme#string->number) + (char? . scheme#char?) (char=? . scheme#char=?) + (char>? . scheme#char>?) (char=? . scheme#char>=?) (char<=? . scheme#char<=?) + (char-ci=? . scheme#char-ci=?) + (char-ci? . scheme#char-ci>?) + (char-ci>=? . scheme#char-ci>=?) (char-ci<=? . scheme#char-ci<=?) + (char-alphabetic? . scheme#char-alphabetic?) + (char-whitespace? . scheme#char-whitespace?) + (char-numeric? . scheme#char-numeric?) + (char-upper-case? . scheme#char-upper-case?) + (char-lower-case? . scheme#char-lower-case?) + (char-upcase . scheme#char-upcase) + (char-downcase . scheme#char-downcase) + (char->integer . scheme#char->integer) + (integer->char . scheme#integer->char) + (string? . scheme#string?) (string=? . scheme#string=?) + (string>? . scheme#string>?) (string=? . scheme#string>=?) (string<=? . scheme#string<=?) + (string-ci=? . scheme#string-ci=?) + (string-ci? . scheme#string-ci>?) + (string-ci>=? . scheme#string-ci>=?) + (string-ci<=? . scheme#string-ci<=?) + (make-string . scheme#make-string) + (string-length . scheme#string-length) + (string-ref . scheme#string-ref) + (string-set! . scheme#string-set!) + (string-append . scheme#string-append) + (string-copy . scheme#string-copy) + (string->list . scheme#string->list) + (list->string . scheme#list->string) + (substring . scheme#substring) + (string-fill! . scheme#string-fill!) + (vector? . scheme#vector?) (make-vector . scheme#make-vector) + (vector-ref . scheme#vector-ref) + (vector-set! . scheme#vector-set!) + (string . scheme#string) (vector . scheme#vector) + (vector-length . scheme#vector-length) + (vector->list . scheme#vector->list) + (list->vector . scheme#list->vector) + (vector-fill! . scheme#vector-fill!) + (procedure? . scheme#procedure?) + (map . scheme#map) (for-each . scheme#for-each) + (apply . scheme#apply) (force . scheme#force) + (call-with-current-continuation . scheme#call-with-current-continuation) + (input-port? . scheme#input-port?) + (output-port? . scheme#output-port?) + (current-input-port . scheme#current-input-port) + (current-output-port . scheme#current-output-port) + (call-with-input-file . scheme#call-with-input-file) + (call-with-output-file . scheme#call-with-output-file) + (open-input-file . scheme#open-input-file) + (open-output-file . scheme#open-output-file) + (close-input-port . scheme#close-input-port) + (close-output-port . scheme#close-output-port) + (load . chicken.load#load) (read . scheme#read) + (read-char . scheme#read-char) (peek-char . scheme#peek-char) + (write . scheme#write) (display . scheme#display) + (write-char . scheme#write-char) (newline . scheme#newline) + (eof-object? . scheme#eof-object?) + (with-input-from-file . scheme#with-input-from-file) + (with-output-to-file . scheme#with-output-to-file) + (eval . chicken.eval#eval) (char-ready? . scheme#char-ready?) + (imag-part . scheme#imag-part) (real-part . scheme#real-part) + (make-rectangular . scheme#make-rectangular) + (make-polar . scheme#make-polar) + (angle . scheme#angle) (magnitude . scheme#magnitude) + (numerator . scheme#numerator) + (denominator . scheme#denominator) + (scheme-report-environment . chicken.eval#scheme-report-environment) + (null-environment . chicken.eval#null-environment) + (interaction-environment . chicken.eval#interaction-environment))) (r4rs-syntax ;;XXX better would be to move these into the "chicken" ;; module. "import[-for-syntax]" and "reexport" are in @@ -944,7 +1036,10 @@ (##sys#register-core-module 'r4rs 'library r4rs-values r4rs-syntax) (##sys#register-core-module 'scheme 'library - (append '(dynamic-wind values call-with-values) r4rs-values) + (append '((dynamic-wind . scheme#dynamic-wind) + (values . scheme#values) + (call-with-values . scheme#call-with-values)) + r4rs-values) r4rs-syntax) (##sys#register-core-module 'r4rs-null #f '() r4rs-syntax) (##sys#register-core-module 'r5rs-null #f '() r4rs-syntax)) diff --git a/scrutinizer.scm b/scrutinizer.scm index 141338a5..90afe0fe 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -2202,10 +2202,10 @@ (list (list-ref (cdr arg1) index))) rtypes)) - (define-special-case vector-ref vector-ref-result-type) + (define-special-case scheme#vector-ref vector-ref-result-type) (define-special-case ##sys#vector-ref vector-ref-result-type) - (define-special-case vector-set! + (define-special-case scheme#vector-set! (lambda (node args loc rtypes) (or (and-let* ((index (known-length-vector-index node args loc 3)) (subs (node-subexpressions node)) @@ -2300,17 +2300,17 @@ (else #f))) rtypes))) - (define-special-case list-ref + (define-special-case scheme#list-ref (list+index-call-result-type-special-case (lambda (_ result-type) (and (pair? result-type) (list (cadr result-type)))))) - (define-special-case list-tail + (define-special-case scheme#list-tail (list+index-call-result-type-special-case (lambda (_ result-type) (list result-type))))) -(define-special-case list +(define-special-case scheme#list (lambda (node args loc rtypes) (if (null? (cdr args)) '(null) @@ -2322,7 +2322,7 @@ '(null) `((list ,@(map walked-result (cdr args))))))) -(define-special-case vector +(define-special-case scheme#vector (lambda (node args loc rtypes) `((vector ,@(map walked-result (cdr args)))))) @@ -2330,7 +2330,7 @@ (lambda (node args loc rtypes) `((vector ,@(map walked-result (cdr args)))))) -(define-special-case reverse +(define-special-case scheme#reverse (lambda (node args loc rtypes) (or (and-let* ((subs (node-subexpressions node)) ((= (length subs) 2)) @@ -2389,7 +2389,7 @@ (cond ((derive-result-type) => list) (else rtypes))) - (define-special-case append append-special-case) + (define-special-case scheme#append append-special-case) (define-special-case ##sys#append append-special-case)) ;;; Special cases for make-list/make-vector with a known size @@ -2413,7 +2413,7 @@ `((,type ,@(make-list size fill)))) rtypes))) - (define-special-case make-vector + (define-special-case scheme#make-vector (complex-object-constructor-result-type-special-case 'vector))) diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected index bd2c6f72..90582764 100644 --- a/tests/scrutiny-2.expected +++ b/tests/scrutiny-2.expected @@ -1,45 +1,45 @@ Note: at toplevel: - (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true + (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate is called with an argument of type `pair' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false + (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate is called with an argument of type `null' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false + (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate is called with an argument of type `null' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false + (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false + (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate is called with an argument of type `float' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type `null' and will always return true + (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate is called with an argument of type `null' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type `null' and will always return true + (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate is called with an argument of type `null' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type `fixnum' and will always return false + (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type `float' and will always return false + (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate is called with an argument of type `float' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type `null' and will always return true + (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate is called with an argument of type `null' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type `null' and will always return true + (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate is called with an argument of type `null' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type `pair' and will always return false + (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate is called with an argument of type `pair' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type `fixnum' and will always return false + (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type `float' and will always return false + (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate is called with an argument of type `float' and will always return false Note: at toplevel: (scrutiny-tests-2.scm:23) in procedure call to `chicken.base#fixnum?', the predicate is called with an argument of type `fixnum' and will always return true @@ -54,13 +54,13 @@ Note: at toplevel: (scrutiny-tests-2.scm:25) in procedure call to `chicken.base#flonum?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type `fixnum' and will always return true + (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the predicate is called with an argument of type `fixnum' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type `float' and will always return true + (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the predicate is called with an argument of type `float' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type `number' and will always return true + (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the predicate is called with an argument of type `number' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type `null' and will always return false + (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the predicate is called with an argument of type `null' and will always return false diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected index d8c3b8fb..44afef85 100644 --- a/tests/scrutiny.expected +++ b/tests/scrutiny.expected @@ -16,31 +16,31 @@ Note: in toplevel procedure `b': Warning: in toplevel procedure `foo': branches in conditional expression differ in the number of results: -(if x (values 1 2) (values 1 2 (+ (+ ...)))) +(if x (scheme#values 1 2) (scheme#values 1 2 (scheme#+ (scheme#+ ...)))) Warning: at toplevel: (scrutiny-tests.scm:19) in procedure call to `bar', expected argument #2 of type `number' but was given an argument of type `symbol' Warning: at toplevel: - (scrutiny-tests.scm:21) in procedure call to `string?', expected 1 argument but was given 0 arguments + (scrutiny-tests.scm:21) in procedure call to `scheme#string?', expected 1 argument but was given 0 arguments Warning: at toplevel: - (scrutiny-tests.scm:23) expected a single result in argument #1 of procedure call `(chicken.base#print (values 1 2))', but received 2 results + (scrutiny-tests.scm:23) expected a single result in argument #1 of procedure call `(chicken.base#print (scheme#values 1 2))', but received 2 results Warning: at toplevel: - (scrutiny-tests.scm:24) expected a single result in argument #1 of procedure call `(chicken.base#print (values))', but received zero results + (scrutiny-tests.scm:24) expected a single result in argument #1 of procedure call `(chicken.base#print (scheme#values))', but received zero results Warning: at toplevel: (scrutiny-tests.scm:27) in procedure call to `x', expected a value of type `(procedure () *)' but was given a value of type `fixnum' Warning: at toplevel: - (scrutiny-tests.scm:29) in procedure call to `+', expected argument #1 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:29) in procedure call to `scheme#+', expected argument #1 of type `number' but was given an argument of type `symbol' Warning: at toplevel: - (scrutiny-tests.scm:29) in procedure call to `+', expected argument #2 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:29) in procedure call to `scheme#+', expected argument #2 of type `number' but was given an argument of type `symbol' Warning: at toplevel: - assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a) (procedure car ((pair a *)) a))' + assignment of value of type `fixnum' to toplevel variable `scheme#car' does not match declared type `(forall (a) (procedure scheme#car ((pair a *)) a))' Warning: at toplevel: expected a single result in `let' binding of `g19', but received 2 results @@ -54,34 +54,34 @@ Note: in toplevel procedure `foo': (if bar 3 (##core#undefined)) Warning: in toplevel procedure `foo2': - (scrutiny-tests.scm:58) in procedure call to `string-append', expected argument #1 of type `string' but was given an argument of type `number' + (scrutiny-tests.scm:58) in procedure call to `scheme#string-append', expected argument #1 of type `string' but was given an argument of type `number' Warning: at toplevel: (scrutiny-tests.scm:66) in procedure call to `foo3', expected argument #1 of type `string' but was given an argument of type `fixnum' Warning: in toplevel procedure `foo4': - (scrutiny-tests.scm:71) in procedure call to `+', expected argument #1 of type `number' but was given an argument of type `string' + (scrutiny-tests.scm:71) in procedure call to `scheme#+', expected argument #1 of type `number' but was given an argument of type `string' Warning: in toplevel procedure `foo5': - (scrutiny-tests.scm:77) in procedure call to `+', expected argument #1 of type `number' but was given an argument of type `string' + (scrutiny-tests.scm:77) in procedure call to `scheme#+', expected argument #1 of type `number' but was given an argument of type `string' Warning: in toplevel procedure `foo6': - (scrutiny-tests.scm:83) in procedure call to `+', expected argument #1 of type `number' but was given an argument of type `string' + (scrutiny-tests.scm:83) in procedure call to `scheme#+', expected argument #1 of type `number' but was given an argument of type `string' Warning: at toplevel: - (scrutiny-tests.scm:90) in procedure call to `+', expected argument #1 of type `number' but was given an argument of type `string' + (scrutiny-tests.scm:90) in procedure call to `scheme#+', expected argument #1 of type `number' but was given an argument of type `string' Warning: in toplevel procedure `foo10': (scrutiny-tests.scm:104) in procedure call to `foo9', expected argument #1 of type `string' but was given an argument of type `number' Warning: in toplevel procedure `foo10': - (scrutiny-tests.scm:105) in procedure call to `+', expected argument #1 of type `number' but was given an argument of type `string' + (scrutiny-tests.scm:105) in procedure call to `scheme#+', expected argument #1 of type `number' but was given an argument of type `string' Note: in toplevel procedure `foo10': expression returns a result of type `string' but is declared to return `pair', which is not compatible Warning: in toplevel procedure `foo10': - (scrutiny-tests.scm:109) in procedure call to `string-append', expected argument #1 of type `string' but was given an argument of type `pair' + (scrutiny-tests.scm:109) in procedure call to `scheme#string-append', expected argument #1 of type `string' but was given an argument of type `pair' Warning: in toplevel procedure `foo10': expression returns 2 values but is declared to have a single result @@ -90,10 +90,10 @@ Warning: in toplevel procedure `foo10': expression returns zero values but is declared to have a single result of type `*' Warning: in toplevel procedure `foo10': - (scrutiny-tests.scm:112) in procedure call to `*', expected argument #1 of type `number' but was given an argument of type `string' + (scrutiny-tests.scm:112) in procedure call to `scheme#*', expected argument #1 of type `number' but was given an argument of type `string' Warning: in toplevel procedure `foo#blabla': - (scrutiny-tests.scm:137) in procedure call to `+', expected argument #2 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:137) in procedure call to `scheme#+', expected argument #2 of type `number' but was given an argument of type `symbol' Warning: at toplevel: use of deprecated `deprecated-procedure' @@ -111,31 +111,31 @@ Note: at toplevel: (scrutiny-tests.scm:176) in procedure call to `chicken.base#fixnum?', the predicate is called with an argument of type `fixnum' and will always return true Note: at toplevel: - (scrutiny-tests.scm:184) in procedure call to `symbol?', the predicate is called with an argument of type `(or char string)' and will always return false + (scrutiny-tests.scm:184) in procedure call to `scheme#symbol?', the predicate is called with an argument of type `(or char string)' and will always return false Note: at toplevel: - (scrutiny-tests.scm:185) in procedure call to `string?', the predicate is called with an argument of type `(not (or char string))' and will always return false + (scrutiny-tests.scm:185) in procedure call to `scheme#string?', the predicate is called with an argument of type `(not (or char string))' and will always return false Note: at toplevel: (scrutiny-tests.scm:188) in procedure call to `char-or-string?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: - (scrutiny-tests.scm:189) in procedure call to `symbol?', the predicate is called with an argument of type `(or char string)' and will always return false + (scrutiny-tests.scm:189) in procedure call to `scheme#symbol?', the predicate is called with an argument of type `(or char string)' and will always return false Note: at toplevel: - (scrutiny-tests.scm:190) in procedure call to `string?', the predicate is called with an argument of type `fixnum' and will always return false + (scrutiny-tests.scm:190) in procedure call to `scheme#string?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: - (scrutiny-tests.scm:194) in procedure call to `symbol?', the predicate is called with an argument of type `char' and will always return false + (scrutiny-tests.scm:194) in procedure call to `scheme#symbol?', the predicate is called with an argument of type `char' and will always return false Note: at toplevel: - (scrutiny-tests.scm:195) in procedure call to `string?', the predicate is called with an argument of type `symbol' and will always return false + (scrutiny-tests.scm:195) in procedure call to `scheme#string?', the predicate is called with an argument of type `symbol' and will always return false Note: at toplevel: - (scrutiny-tests.scm:199) in procedure call to `symbol?', the predicate is called with an argument of type `(or char string)' and will always return false + (scrutiny-tests.scm:199) in procedure call to `scheme#symbol?', the predicate is called with an argument of type `(or char string)' and will always return false Note: at toplevel: - (scrutiny-tests.scm:200) in procedure call to `string?', the predicate is called with an argument of type `symbol' and will always return false + (scrutiny-tests.scm:200) in procedure call to `scheme#string?', the predicate is called with an argument of type `symbol' and will always return false Warning: at toplevel: (scrutiny-tests.scm:204) in procedure call to `f', expected argument #1 of type `pair' but was given an argument of type `null' @@ -147,55 +147,55 @@ Warning: at toplevel: (scrutiny-tests.scm:208) in procedure call to `f', expected argument #1 of type `list' but was given an argument of type `(pair fixnum fixnum)' Warning: in toplevel procedure `vector-ref-warn1': - (scrutiny-tests.scm:214) in procedure call to `vector-ref', index -1 out of range for vector of length 3 + (scrutiny-tests.scm:214) in procedure call to `scheme#vector-ref', index -1 out of range for vector of length 3 Warning: in toplevel procedure `vector-ref-warn2': - (scrutiny-tests.scm:216) in procedure call to `vector-ref', index 3 out of range for vector of length 3 + (scrutiny-tests.scm:216) in procedure call to `scheme#vector-ref', index 3 out of range for vector of length 3 Warning: in toplevel procedure `vector-ref-warn3': - (scrutiny-tests.scm:217) in procedure call to `vector-ref', index 4 out of range for vector of length 3 + (scrutiny-tests.scm:217) in procedure call to `scheme#vector-ref', index 4 out of range for vector of length 3 Warning: in toplevel procedure `vector-ref-standard-warn1': - (scrutiny-tests.scm:220) in procedure call to `vector-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' + (scrutiny-tests.scm:220) in procedure call to `scheme#vector-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `vector-set!-warn1': - (scrutiny-tests.scm:221) in procedure call to `vector-set!', index -1 out of range for vector of length 3 + (scrutiny-tests.scm:221) in procedure call to `scheme#vector-set!', index -1 out of range for vector of length 3 Warning: in toplevel procedure `vector-set!-warn2': - (scrutiny-tests.scm:222) in procedure call to `vector-set!', index 3 out of range for vector of length 3 + (scrutiny-tests.scm:222) in procedure call to `scheme#vector-set!', index 3 out of range for vector of length 3 Warning: in toplevel procedure `vector-set!-warn3': - (scrutiny-tests.scm:223) in procedure call to `vector-set!', index 4 out of range for vector of length 3 + (scrutiny-tests.scm:223) in procedure call to `scheme#vector-set!', index 4 out of range for vector of length 3 Warning: in toplevel procedure `vector-set!-standard-warn1': - (scrutiny-tests.scm:226) in procedure call to `vector-set!', expected argument #2 of type `fixnum' but was given an argument of type `symbol' + (scrutiny-tests.scm:226) in procedure call to `scheme#vector-set!', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-warn1': - (scrutiny-tests.scm:232) in procedure call to `list-ref', index -1 is negative, which is never valid + (scrutiny-tests.scm:232) in procedure call to `scheme#list-ref', index -1 is negative, which is never valid Warning: in toplevel procedure `list-ref-warn2': - (scrutiny-tests.scm:235) in procedure call to `list-ref', index -1 is negative, which is never valid + (scrutiny-tests.scm:235) in procedure call to `scheme#list-ref', index -1 is negative, which is never valid Warning: in toplevel procedure `list-ref-warn3': - (scrutiny-tests.scm:238) in procedure call to `list-ref', index -1 is negative, which is never valid + (scrutiny-tests.scm:238) in procedure call to `scheme#list-ref', index -1 is negative, which is never valid Warning: in toplevel procedure `list-ref-warn4': - (scrutiny-tests.scm:240) in procedure call to `list-ref', index 3 out of range for proper list of length 3 + (scrutiny-tests.scm:240) in procedure call to `scheme#list-ref', index 3 out of range for proper list of length 3 Warning: in toplevel procedure `list-ref-warn5': - (scrutiny-tests.scm:246) in procedure call to `list-ref', index 4 out of range for proper list of length 3 + (scrutiny-tests.scm:246) in procedure call to `scheme#list-ref', index 4 out of range for proper list of length 3 Warning: in toplevel procedure `list-ref-standard-warn1': - (scrutiny-tests.scm:275) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' + (scrutiny-tests.scm:275) in procedure call to `scheme#list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-standard-warn2': - (scrutiny-tests.scm:276) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' + (scrutiny-tests.scm:276) in procedure call to `scheme#list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-standard-warn3': - (scrutiny-tests.scm:278) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' + (scrutiny-tests.scm:278) in procedure call to `scheme#list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-standard-warn4': - (scrutiny-tests.scm:279) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' + (scrutiny-tests.scm:279) in procedure call to `scheme#list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-type-warn1': (scrutiny-tests.scm:283) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' @@ -212,4 +212,4 @@ Warning: in toplevel procedure `append-result-type-warn1': Warning: in toplevel procedure `append-result-type-warn2': (scrutiny-tests.scm:306) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' -Warning: redefinition of standard binding: car +Warning: redefinition of standard binding: scheme#car diff --git a/tests/specialization.expected b/tests/specialization.expected index 8b47dcc9..fed76b6b 100644 --- a/tests/specialization.expected +++ b/tests/specialization.expected @@ -1,32 +1,32 @@ Note: at toplevel: - (specialization-tests.scm:3) in procedure call to `string?', the predicate is called with an argument of type `string' and will always return true + (specialization-tests.scm:3) in procedure call to `scheme#string?', the predicate is called with an argument of type `string' and will always return true Note: at toplevel: (specialization-tests.scm:3) expected a value of type boolean in conditional, but was given a value of type `true' which is always true: -(if (string? a) 'ok 'no) +(if (scheme#string? a) 'ok 'no) Note: at toplevel: - (specialization-tests.scm:4) in procedure call to `string?', the predicate is called with an argument of type `symbol' and will always return false + (specialization-tests.scm:4) in procedure call to `scheme#string?', the predicate is called with an argument of type `symbol' and will always return false Note: at toplevel: (specialization-tests.scm:4) in conditional, test expression will always return false: -(if (string? a) 'ok 'no) +(if (scheme#string? a) 'ok 'no) Note: at toplevel: - (specialization-tests.scm:10) in procedure call to `input-port?', the predicate is called with an argument of type `input/output-port' and will always return true + (specialization-tests.scm:10) in procedure call to `scheme#input-port?', the predicate is called with an argument of type `input/output-port' and will always return true Note: at toplevel: (specialization-tests.scm:10) expected a value of type boolean in conditional, but was given a value of type `true' which is always true: -(if (input-port? p) 'ok 'no) +(if (scheme#input-port? p) 'ok 'no) Note: at toplevel: - (specialization-tests.scm:11) in procedure call to `output-port?', the predicate is called with an argument of type `input/output-port' and will always return true + (specialization-tests.scm:11) in procedure call to `scheme#output-port?', the predicate is called with an argument of type `input/output-port' and will always return true Note: at toplevel: (specialization-tests.scm:11) expected a value of type boolean in conditional, but was given a value of type `true' which is always true: -(if (output-port? p) 'ok 'no) +(if (scheme#output-port? p) 'ok 'no) diff --git a/tests/test-finalizers-2.scm b/tests/test-finalizers-2.scm index 3f1170c6..051bf70b 100644 --- a/tests/test-finalizers-2.scm +++ b/tests/test-finalizers-2.scm @@ -8,14 +8,6 @@ '() (cons (proc i) (loop (fx+ i 1)))))) -(define (circular-list x1 . lst) - (let ((lst1 (cons x1 lst))) - (let loop ((lst lst1)) - (if (null? (cdr lst)) - (set-cdr! lst lst1) - (loop (cdr lst)))) - lst1)) - (define *n* 1000) (define *count* 0) @@ -48,7 +40,7 @@ freef(void *r) (print "creating gc roots") (let* ((x (list-tabulate *n* list)) - (fs (circular-list #t #f)) + (fs (list-tabulate *n* (lambda (x) (zero? (modulo x 2))))) (rs (map makef fs x))) (for-each (lambda (x f e) diff --git a/types.db b/types.db index d2c9a3f8..361a723f 100644 --- a/types.db +++ b/types.db @@ -53,116 +53,116 @@ ;; scheme -(not (#(procedure #:pure #:foldable) not (*) boolean) - ((true) (false) (let ((#(tmp) #(1))) '#f)) - ((false) (true) (let ((#(tmp) #(1))) '#t)) - (((not boolean)) (false) (let ((#(tmp) #(1))) '#f))) +(scheme#not (#(procedure #:pure #:foldable) scheme#not (*) boolean) + ((true) (false) (let ((#(tmp) #(1))) '#f)) + ((false) (true) (let ((#(tmp) #(1))) '#t)) + (((not boolean)) (false) (let ((#(tmp) #(1))) '#f))) -(boolean? (#(procedure #:pure #:predicate boolean) boolean? (*) boolean)) +(scheme#boolean? (#(procedure #:pure #:predicate boolean) scheme#boolean? (*) boolean)) -(eq? (#(procedure #:pure #:foldable) eq? (* *) boolean)) +(scheme#eq? (#(procedure #:pure #:foldable) scheme#eq? (* *) boolean)) -(eqv? (#(procedure #:pure #:foldable) eqv? (* *) boolean) - (((or immediate symbol) *) (eq? #(1) #(2))) - ((* (or immediate symbol)) (eq? #(1) #(2))) - ((* *) (##core#inline "C_i_eqvp" #(1) #(2)))) +(scheme#eqv? (#(procedure #:pure #:foldable) scheme#eqv? (* *) boolean) + (((or immediate symbol) *) (scheme#eq? #(1) #(2))) + ((* (or immediate symbol)) (scheme#eq? #(1) #(2))) + ((* *) (##core#inline "C_i_eqvp" #(1) #(2)))) -(equal? (#(procedure #:pure #:foldable) equal? (* *) boolean) - (((or immediate symbol) *) (eq? #(1) #(2))) - ((* (or immediate symbol)) (eq? #(1) #(2))) - ((number number) (##core#inline "C_i_eqvp" #(1) #(2)))) +(scheme#equal? (#(procedure #:pure #:foldable) scheme#equal? (* *) boolean) + (((or immediate symbol) *) (scheme#eq? #(1) #(2))) + ((* (or immediate symbol)) (scheme#eq? #(1) #(2))) + ((number number) (##core#inline "C_i_eqvp" #(1) #(2)))) -(pair? (#(procedure #:pure #:predicate pair) pair? (*) boolean)) +(scheme#pair? (#(procedure #:pure #:predicate pair) scheme#pair? (*) boolean)) -(cons (forall (a b) (#(procedure #:pure) cons (a b) (pair a b)))) +(scheme#cons (forall (a b) (#(procedure #:pure) scheme#cons (a b) (pair a b)))) (##sys#cons (forall (a b) (#(procedure #:pure) ##sys#cons (a b) (pair a b)))) -(car (forall (a) (#(procedure #:clean #:enforce #:foldable) car ((pair a *)) a)) ((pair) (##core#inline "C_u_i_car" #(1)))) -(cdr (forall (a) (#(procedure #:clean #:enforce #:foldable) cdr ((pair * a)) a)) ((pair) (##core#inline "C_u_i_cdr" #(1)))) - -(caar (forall (a) (#(procedure #:clean #:enforce #:foldable) caar ((pair (pair a *) *)) a)) - (((pair (pair * *) *)) (##core#inline "C_u_i_car" (##core#inline "C_u_i_car" #(1))))) -(cadr (forall (a) (#(procedure #:clean #:enforce #:foldable) cadr ((pair * (pair a *))) a)) - (((pair * (pair * *))) (##core#inline "C_u_i_car" (##core#inline "C_u_i_cdr" #(1))))) -(cdar (forall (a) (#(procedure #:clean #:enforce #:foldable) cdar ((pair (pair * a) *)) a)) - (((pair (pair * *) *)) (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_car" #(1))))) -(cddr (forall (a) (#(procedure #:clean #:enforce #:foldable) cddr ((pair * (pair * a))) a)) - (((pair * (pair * *))) (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_cdr" #(1))))) - -(caaar (forall (a) (#(procedure #:clean #:enforce #:foldable) caaar ((pair (pair (pair a *) *) *)) a)) - (((pair (pair (pair * *) *) *)) - (##core#inline "C_u_i_car" - (##core#inline "C_u_i_car" (##core#inline "C_u_i_car" #(1)))))) - -(caadr (forall (a) (#(procedure #:clean #:enforce #:foldable) caadr ((pair * (pair (pair a *) *))) a)) - (((pair * (pair (pair * *) *))) - (##core#inline "C_u_i_car" - (##core#inline "C_u_i_car" (##core#inline "C_u_i_cdr" #(1)))))) - -(cadar (forall (a) (#(procedure #:clean #:enforce #:foldable) cadar ((pair (pair * (pair a *)) *)) a)) - (((pair (pair * (pair * *)) *)) - (##core#inline "C_u_i_car" - (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_car" #(1)))))) - -(caddr (forall (a) (#(procedure #:clean #:enforce #:foldable) caddr ((pair * (pair * (pair a *)))) a)) - (((pair * (pair * (pair * *)))) - (##core#inline "C_u_i_car" - (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_cdr" #(1)))))) - -(cdaar (forall (a) (#(procedure #:clean #:enforce #:foldable) cdaar ((pair (pair (pair * a) *) *)) a)) - (((pair (pair (pair * *) *) *)) - (##core#inline "C_u_i_cdr" - (##core#inline "C_u_i_car" (##core#inline "C_u_i_car" #(1)))))) - -(cdadr (forall (a) (#(procedure #:clean #:enforce #:foldable) cdadr ((pair * (pair (pair * a) *))) a)) - (((pair * (pair (pair * *) *))) - (##core#inline "C_u_i_cdr" - (##core#inline "C_u_i_car" (##core#inline "C_u_i_cdr" #(1)))))) - -(cddar (forall (a) (#(procedure #:clean #:enforce #:foldable) cddar ((pair (pair * (pair * a)) *)) a)) - (((pair (pair * (pair * *)) *)) - (##core#inline "C_u_i_cdr" - (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_car" #(1)))))) - -(cdddr (forall (a) (#(procedure #:clean #:enforce #:foldable) cdddr ((pair * (pair * (pair * a)))) a)) - (((pair * (pair * (pair * *)))) - (##core#inline "C_u_i_cdr" - (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_cdr" #(1)))))) - -(caaaar (forall (a) (#(procedure #:clean #:enforce #:foldable) caaaar ((pair (pair (pair (pair a *) *) *) *)) a))) -(caaadr (forall (a) (#(procedure #:clean #:enforce #:foldable) caaadr ((pair * (pair (pair (pair a *) *) *))) a))) -(caadar (forall (a) (#(procedure #:clean #:enforce #:foldable) caadar ((pair (pair * (pair (pair a *) *)) *)) a))) -(caaddr (forall (a) (#(procedure #:clean #:enforce #:foldable) caaddr ((pair * (pair * (pair (pair a *) *)))) a))) -(cadaar (forall (a) (#(procedure #:clean #:enforce #:foldable) cadaar ((pair (pair (pair * (pair a *)) *) *)) a))) -(cadadr (forall (a) (#(procedure #:clean #:enforce #:foldable) cadadr ((pair * (pair (pair * (pair a *)) *))) a))) -(caddar (forall (a) (#(procedure #:clean #:enforce #:foldable) caddar ((pair (pair * (pair * (pair a *))) *)) a))) -(cadddr (forall (a) (#(procedure #:clean #:enforce #:foldable) cadddr ((pair * (pair * (pair * (pair a *))))) a))) -(cdaaar (forall (a) (#(procedure #:clean #:enforce #:foldable) cdaaar ((pair (pair (pair (pair * a) *) *) *)) a))) -(cdaadr (forall (a) (#(procedure #:clean #:enforce #:foldable) cdaadr ((pair * (pair (pair (pair * a) *) *))) a))) -(cdadar (forall (a) (#(procedure #:clean #:enforce #:foldable) cdadar ((pair (pair * (pair (pair * a) *)) *)) a))) -(cdaddr (forall (a) (#(procedure #:clean #:enforce #:foldable) cdaddr ((pair * (pair * (pair (pair * a) *)))) a))) -(cddaar (forall (a) (#(procedure #:clean #:enforce #:foldable) cddaar ((pair (pair (pair * (pair * a)) *) *)) a))) -(cddadr (forall (a) (#(procedure #:clean #:enforce #:foldable) cddadr ((pair * (pair (pair * (pair * a)) *))) a))) -(cdddar (forall (a) (#(procedure #:clean #:enforce #:foldable) cdddar ((pair (pair * (pair * (pair * a))) *)) a))) -(cddddr (forall (a) (#(procedure #:clean #:enforce #:foldable) cddddr ((pair * (pair * (pair * (pair * a))))) a))) - -(set-car! (#(procedure #:enforce) set-car! (pair *) undefined) - ((pair (or fixnum char boolean eof null undefined)) (##sys#setislot #(1) '0 #(2))) - ((pair *) (##sys#setslot #(1) '0 #(2)))) - -(set-cdr! (#(procedure #:enforce) set-cdr! (pair *) undefined) - ((pair (or fixnum char boolean eof null undefined)) (##sys#setislot #(1) '1 #(2))) - ((pair *) (##sys#setslot #(1) '1 #(2)))) - -(null? (#(procedure #:pure #:predicate null) null? (*) boolean)) -(list? (#(procedure #:pure #:predicate list) list? (*) boolean)) +(scheme#car (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#car ((pair a *)) a)) ((pair) (##core#inline "C_u_i_car" #(1)))) +(scheme#cdr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdr ((pair * a)) a)) ((pair) (##core#inline "C_u_i_cdr" #(1)))) + +(scheme#caar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caar ((pair (pair a *) *)) a)) + (((pair (pair * *) *)) (##core#inline "C_u_i_car" (##core#inline "C_u_i_car" #(1))))) +(scheme#cadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cadr ((pair * (pair a *))) a)) + (((pair * (pair * *))) (##core#inline "C_u_i_car" (##core#inline "C_u_i_cdr" #(1))))) +(scheme#cdar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdar ((pair (pair * a) *)) a)) + (((pair (pair * *) *)) (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_car" #(1))))) +(scheme#cddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cddr ((pair * (pair * a))) a)) + (((pair * (pair * *))) (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_cdr" #(1))))) + +(scheme#caaar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caaar ((pair (pair (pair a *) *) *)) a)) + (((pair (pair (pair * *) *) *)) + (##core#inline "C_u_i_car" + (##core#inline "C_u_i_car" (##core#inline "C_u_i_car" #(1)))))) + +(scheme#caadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caadr ((pair * (pair (pair a *) *))) a)) + (((pair * (pair (pair * *) *))) + (##core#inline "C_u_i_car" + (##core#inline "C_u_i_car" (##core#inline "C_u_i_cdr" #(1)))))) + +(scheme#cadar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cadar ((pair (pair * (pair a *)) *)) a)) + (((pair (pair * (pair * *)) *)) + (##core#inline "C_u_i_car" + (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_car" #(1)))))) + +(scheme#caddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caddr ((pair * (pair * (pair a *)))) a)) + (((pair * (pair * (pair * *)))) + (##core#inline "C_u_i_car" + (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_cdr" #(1)))))) + +(scheme#cdaar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdaar ((pair (pair (pair * a) *) *)) a)) + (((pair (pair (pair * *) *) *)) + (##core#inline "C_u_i_cdr" + (##core#inline "C_u_i_car" (##core#inline "C_u_i_car" #(1)))))) + +(scheme#cdadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdadr ((pair * (pair (pair * a) *))) a)) + (((pair * (pair (pair * *) *))) + (##core#inline "C_u_i_cdr" + (##core#inline "C_u_i_car" (##core#inline "C_u_i_cdr" #(1)))))) + +(scheme#cddar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cddar ((pair (pair * (pair * a)) *)) a)) + (((pair (pair * (pair * *)) *)) + (##core#inline "C_u_i_cdr" + (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_car" #(1)))))) + +(scheme#cdddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdddr ((pair * (pair * (pair * a)))) a)) + (((pair * (pair * (pair * *)))) + (##core#inline "C_u_i_cdr" + (##core#inline "C_u_i_cdr" (##core#inline "C_u_i_cdr" #(1)))))) + +(scheme#caaaar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caaaar ((pair (pair (pair (pair a *) *) *) *)) a))) +(scheme#caaadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caaadr ((pair * (pair (pair (pair a *) *) *))) a))) +(scheme#caadar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caadar ((pair (pair * (pair (pair a *) *)) *)) a))) +(scheme#caaddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caaddr ((pair * (pair * (pair (pair a *) *)))) a))) +(scheme#cadaar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cadaar ((pair (pair (pair * (pair a *)) *) *)) a))) +(scheme#cadadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cadadr ((pair * (pair (pair * (pair a *)) *))) a))) +(scheme#caddar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#caddar ((pair (pair * (pair * (pair a *))) *)) a))) +(scheme#cadddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cadddr ((pair * (pair * (pair * (pair a *))))) a))) +(scheme#cdaaar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdaaar ((pair (pair (pair (pair * a) *) *) *)) a))) +(scheme#cdaadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdaadr ((pair * (pair (pair (pair * a) *) *))) a))) +(scheme#cdadar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdadar ((pair (pair * (pair (pair * a) *)) *)) a))) +(scheme#cdaddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdaddr ((pair * (pair * (pair (pair * a) *)))) a))) +(scheme#cddaar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cddaar ((pair (pair (pair * (pair * a)) *) *)) a))) +(scheme#cddadr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cddadr ((pair * (pair (pair * (pair * a)) *))) a))) +(scheme#cdddar (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cdddar ((pair (pair * (pair * (pair * a))) *)) a))) +(scheme#cddddr (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#cddddr ((pair * (pair * (pair * (pair * a))))) a))) + +(scheme#set-car! (#(procedure #:enforce) scheme#set-car! (pair *) undefined) + ((pair (or fixnum char boolean eof null undefined)) (##sys#setislot #(1) '0 #(2))) + ((pair *) (##sys#setslot #(1) '0 #(2)))) + +(scheme#set-cdr! (#(procedure #:enforce) scheme#set-cdr! (pair *) undefined) + ((pair (or fixnum char boolean eof null undefined)) (##sys#setislot #(1) '1 #(2))) + ((pair *) (##sys#setslot #(1) '1 #(2)))) + +(scheme#null? (#(procedure #:pure #:predicate null) scheme#null? (*) boolean)) +(scheme#list? (#(procedure #:pure #:predicate list) scheme#list? (*) boolean)) ;; special cased (see scrutinizer.scm) -(list (#(procedure #:pure) list (#!rest) list)) +(scheme#list (#(procedure #:pure) scheme#list (#!rest) list)) (##sys#list (#(procedure #:pure) ##sys#list (#!rest) list)) -(length (#(procedure #:clean #:enforce #:foldable) length (list) fixnum) ; may loop +(scheme#length (#(procedure #:clean #:enforce #:foldable) scheme#length (list) fixnum) ; may loop ((null) (let ((#(tmp) #(1))) '0)) ((list) (##core#inline "C_u_i_length" #(1)))) @@ -171,581 +171,582 @@ ((list) (##core#inline "C_u_i_length" #(1)))) ;; these are special cased (see scrutinizer.scm) -(list-tail (forall (a) (#(procedure #:clean #:enforce #:foldable) list-tail ((list-of a) fixnum) (list-of a)))) -(list-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) list-ref ((list-of a) fixnum) a))) +(scheme#list-tail (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#list-tail ((list-of a) fixnum) (list-of a)))) +(scheme#list-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#list-ref ((list-of a) fixnum) a))) ;; special cased (see scrutinizer.scm) -(append (#(procedure #:clean) append (#!rest *) *)) ; sic +(scheme#append (#(procedure #:clean) scheme#append (#!rest *) *)) ; sic (##sys#append (#(procedure #:clean) ##sys#append (#!rest *) *)) ;; special cased (see scrutinizer.scm) -(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a))) - ((null) (null) (let ((#(tmp) #(1))) '()))) - -(memq (forall (a b) (#(procedure #:clean #:foldable) memq (a (list-of b)) - (or false (pair a (list-of b))))) - ((* null) (let ((#(tmp) #(1))) '#f)) - ((* list) (##core#inline "C_u_i_memq" #(1) #(2)))) - -(memv (forall (a b) (#(procedure #:clean #:foldable) memv (a (list-of b)) - (or false (pair a (list-of b))))) - ((* null) (let ((#(tmp) #(1))) '#f)) - (((or symbol procedure immediate) list) - (##core#inline "C_u_i_memq" #(1) #(2)))) - -(member (forall (a b) (#(procedure #:clean #:foldable) member (a (list-of b)) - (or false (pair a (list-of b))))) - ((* null) (let ((#(tmp) #(1))) '#f)) - (((or symbol procedure immediate) list) - (##core#inline "C_u_i_memq" #(1) #(2))) - ((* (list-of (or symbol procedure immediate))) - (##core#inline "C_u_i_memq" #(1) #(2)))) - -(assq (forall (a b c) (#(procedure #:clean #:foldable) assq - (a (list-of (pair b c))) - (or false (pair a c)))) - ((* null) (let ((#(tmp) #(1))) '#f)) - ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2)))) - -(assv (forall (a b c) (#(procedure #:clean #:foldable) assv - (a (list-of (pair b c))) - (or false (pair a c)))) - ((* null) (let ((#(tmp) #(1))) '#f)) - (((or symbol immediate procedure) (list-of pair)) - (##core#inline "C_u_i_assq" #(1) #(2))) - ((* (list-of (pair (or symbol procedure immediate) *))) - (##core#inline "C_u_i_assq" #(1) #(2)))) - -(assoc (forall (a b c) (#(procedure #:clean #:foldable) assoc - (a (list-of (pair b c))) - (or false (pair a c)))) - ((* null) (let ((#(tmp) #(1))) '#f)) - (((or symbol procedure immediate) (list-of pair)) - (##core#inline "C_u_i_assq" #(1) #(2))) - ((* (list-of (pair (or symbol procedure immediate) *))) - (##core#inline "C_u_i_assq" #(1) #(2)))) - -(symbol? (#(procedure #:pure #:predicate symbol) symbol? (*) boolean)) - -(symbol->string (#(procedure #:clean #:enforce) symbol->string (symbol) string)) -(string->symbol (#(procedure #:clean #:enforce #:foldable) string->symbol (string) symbol)) - -(number? (#(procedure #:pure #:predicate number) number? (*) boolean)) +(scheme#reverse (forall (a) (#(procedure #:clean #:enforce) scheme#reverse ((list-of a)) (list-of a))) + ((null) (null) (let ((#(tmp) #(1))) '()))) + +(scheme#memq (forall (a b) (#(procedure #:clean #:foldable) scheme#memq (a (list-of b)) + (or false (pair a (list-of b))))) + ((* null) (let ((#(tmp) #(1))) '#f)) + ((* list) (##core#inline "C_u_i_memq" #(1) #(2)))) + +(scheme#memv (forall (a b) (#(procedure #:clean #:foldable) scheme#memv (a (list-of b)) + (or false (pair a (list-of b))))) + ((* null) (let ((#(tmp) #(1))) '#f)) + (((or symbol procedure immediate) list) + (##core#inline "C_u_i_memq" #(1) #(2)))) + +(scheme#member (forall (a b) (#(procedure #:clean #:foldable) scheme#member (a (list-of b)) + (or false (pair a (list-of b))))) + ((* null) (let ((#(tmp) #(1))) '#f)) + (((or symbol procedure immediate) list) + (##core#inline "C_u_i_memq" #(1) #(2))) + ((* (list-of (or symbol procedure immediate))) + (##core#inline "C_u_i_memq" #(1) #(2)))) + +(scheme#assq (forall (a b c) (#(procedure #:clean #:foldable) scheme#assq + (a (list-of (pair b c))) + (or false (pair a c)))) + ((* null) (let ((#(tmp) #(1))) '#f)) + ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2)))) + +(scheme#assv (forall (a b c) (#(procedure #:clean #:foldable) scheme#assv + (a (list-of (pair b c))) + (or false (pair a c)))) + ((* null) (let ((#(tmp) #(1))) '#f)) + (((or symbol immediate procedure) (list-of pair)) + (##core#inline "C_u_i_assq" #(1) #(2))) + ((* (list-of (pair (or symbol procedure immediate) *))) + (##core#inline "C_u_i_assq" #(1) #(2)))) + +(scheme#assoc (forall (a b c) (#(procedure #:clean #:foldable) scheme#assoc + (a (list-of (pair b c))) + (or false (pair a c)))) + ((* null) (let ((#(tmp) #(1))) '#f)) + (((or symbol procedure immediate) (list-of pair)) + (##core#inline "C_u_i_assq" #(1) #(2))) + ((* (list-of (pair (or symbol procedure immediate) *))) + (##core#inline "C_u_i_assq" #(1) #(2)))) + +(scheme#symbol? (#(procedure #:pure #:predicate symbol) scheme#symbol? (*) boolean)) + +(scheme#symbol->string (#(procedure #:clean #:enforce) scheme#symbol->string (symbol) string)) +(scheme#string->symbol (#(procedure #:clean #:enforce #:foldable) scheme#string->symbol (string) symbol)) + +(scheme#number? (#(procedure #:pure #:predicate number) scheme#number? (*) boolean)) ;;XXX predicate? -(integer? (#(procedure #:pure #:foldable) integer? (*) 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) - (((or integer ratnum)) (let ((#(tmp) #(1))) '#t)) - ((float) (let ((#(tmp) #(1))) '#f))) -(inexact? (#(procedure #:clean #:enforce #:foldable) inexact? (number) boolean) - (((or integer ratnum)) (let ((#(tmp) #(1))) '#f)) - ((float) (let ((#(tmp) #(1))) '#t))) +(scheme#integer? (#(procedure #:pure #:foldable) scheme#integer? (*) boolean) + ((integer) (let ((#(tmp) #(1))) '#t)) + ((float) (##core#inline "C_u_i_fpintegerp" #(1))) + ((*) (##core#inline "C_i_integerp" #(1)))) + +(scheme#real? (#(procedure #:pure #:foldable) scheme#real? (*) boolean) + (((or fixnum float bignum ratnum)) (let ((#(tmp) #(1))) '#t)) + ((cplxnum) (let ((#(tmp) #(1))) '#f)) + ((*) (##core#inline "C_i_realp" #(1)))) +(scheme#complex? (#(procedure #:pure #:predicate number) scheme#complex? (*) boolean)) +(scheme#exact? (#(procedure #:clean #:enforce #:foldable) scheme#exact? (number) boolean) + (((or integer ratnum)) (let ((#(tmp) #(1))) '#t)) + ((float) (let ((#(tmp) #(1))) '#f))) +(scheme#inexact? (#(procedure #:clean #:enforce #:foldable) scheme#inexact? (number) boolean) + (((or integer ratnum)) (let ((#(tmp) #(1))) '#f)) + ((float) (let ((#(tmp) #(1))) '#t))) ;;XXX predicate? -(rational? (#(procedure #:pure #:foldable) rational? (*) boolean) - (((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) - ((integer) (eq? #(1) '0)) - (((or cplxnum ratnum)) (let ((#(tmp) #(1))) '#f)) - ((number) (##core#inline "C_u_i_zerop" #(1))) - ((*) (##core#inline "C_i_zerop" #(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_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_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) (chicken.fixnum#fxmax #(1) #(2))) - ((float float) (##core#inline "C_i_flonum_max" #(1) #(2)))) - -(min (#(procedure #:clean #:enforce #:foldable) min (#!rest number) number) - ((fixnum fixnum) (chicken.fixnum#fxmin #(1) #(2))) - ((float float) (##core#inline "C_i_flonum_min" #(1) #(2)))) - -(+ (#(procedure #:clean #:enforce #:foldable) + (#!rest number) number) - (() (fixnum) '0) - ((fixnum) (fixnum) #(1)) - ((float) (float) #(1)) - ((integer) (integer) #(1)) - ((ratnum) (ratnum) #(1)) - ((cplxnum) (cplxnum) #(1)) - ((number) (number) #(1)) - ((float fixnum) (float) - (##core#inline_allocate - ("C_a_i_flonum_plus" 4) - #(1) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) - ((fixnum float) - (float) - (##core#inline_allocate - ("C_a_i_flonum_plus" 4) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) - #(2))) - ((float float) (float) - (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2))) - ((fixnum fixnum) (integer) - (##core#inline_allocate ("C_a_i_fixnum_plus" 5) #(1) #(2))) - ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_plus" 5) #(1) #(2))) - ((* *) (number) - (##core#inline_allocate ("C_s_a_i_plus" 29) #(1) #(2)))) - -(- (#(procedure #:clean #:enforce #:foldable) - (number #!rest number) number) - ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 5) #(1))) - ((integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) #(1))) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1))) - ((*) (*) (##core#inline_allocate ("C_s_a_i_negate" 29) #(1))) - ((float fixnum) (float) - (##core#inline_allocate - ("C_a_i_flonum_difference" 4) - #(1) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) - ((fixnum float) (float) - (##core#inline_allocate - ("C_a_i_flonum_difference" 4) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) - #(2))) - ((float float) (float) - (##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) #(2))) - ((fixnum fixnum) (integer) - (##core#inline_allocate ("C_a_i_fixnum_difference" 5) #(1) #(2))) - ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) #(2))) - ((* *) (number) - (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) #(2)))) - -(* (#(procedure #:clean #:enforce #:foldable) * (#!rest number) number) - (() (fixnum) '1) - ((fixnum) (fixnum) #(1)) - ((float) (float) #(1)) - ((bignum) (bignum) #(1)) - ((integer) (integer) #(1)) - ((ratnum) (ratnum) #(1)) - ((cplxnum) (cplxnum) #(1)) - ((number) (number) #(1)) - ((float fixnum) (float) - (##core#inline_allocate - ("C_a_i_flonum_times" 4) - #(1) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) - ((fixnum float) (float) - (##core#inline_allocate - ("C_a_i_flonum_times" 4) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) - #(2))) - ((float float) (float) - (##core#inline_allocate ("C_a_i_flonum_times" 4) #(1) #(2))) - ((fixnum fixnum) (integer) - (##core#inline_allocate ("C_a_i_fixnum_times" 5) #(1) #(2))) - ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_times" 5) #(1) #(2))) - ((* *) (number) - (##core#inline_allocate ("C_s_a_i_times" 33) #(1) #(2)))) - -(/ (#(procedure #:clean #:enforce #:foldable) / (number #!rest number) number) - ((float fixnum) (float) - ;; This is the only checked one because the divisor is an exact value - (##core#inline_allocate - ("C_a_i_flonum_quotient_checked" 4) - #(1) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) - ((fixnum float) (float) - (##core#inline_allocate - ("C_a_i_flonum_quotient" 4) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) - #(2))) - ((float float) (float) - (##core#inline_allocate ("C_a_i_flonum_quotient" 4) #(1) #(2))) - ((integer integer) ((or integer ratnum)) - (##sys#/-2 #(1) #(2))) - ((* *) (number) - (##sys#/-2 #(1) #(2)))) - -(= (#(procedure #:clean #:enforce #:foldable) = (#!rest number) boolean) - (() '#t) - ((number) (let ((#(tmp) #(1))) '#t)) - ((fixnum fixnum) (eq? #(1) #(2))) - ((float float) (##core#inline "C_flonum_equalp" #(1) #(2))) - ((integer integer) (##core#inline "C_i_integer_equalp" #(1) #(2))) - ((* *) (##core#inline "C_i_nequalp" #(1) #(2)))) - -(> (#(procedure #:clean #:enforce #:foldable) > (#!rest number) boolean) - (() '#t) - ((number) (let ((#(tmp) #(1))) '#t)) - ((fixnum fixnum) (chicken.fixnum#fx> #(1) #(2))) - ((float float) (##core#inline "C_flonum_greaterp" #(1) #(2))) - ((integer integer) (##core#inline "C_i_integer_greaterp" #(1) #(2))) - ((* *) (##core#inline "C_i_greaterp" #(1) #(2)))) - -(< (#(procedure #:clean #:enforce #:foldable) < (#!rest number) boolean) - (() '#t) - ((number) (let ((#(tmp) #(1))) '#t)) - ((fixnum fixnum) (chicken.fixnum#fx< #(1) #(2))) - ((integer integer) (##core#inline "C_i_integer_lessp" #(1) #(2))) - ((float float) (##core#inline "C_flonum_lessp" #(1) #(2))) - ((* *) (##core#inline "C_i_lessp" #(1) #(2)))) - -(>= (#(procedure #:clean #:enforce #:foldable) >= (#!rest number) boolean) - (() '#t) - ((number) (let ((#(tmp) #(1))) '#t)) - ((fixnum fixnum) (chicken.fixnum#fx>= #(1) #(2))) - ((integer integer) (##core#inline "C_i_integer_greater_or_equalp" #(1) #(2))) - ((float float) (##core#inline "C_flonum_greater_or_equal_p" #(1) #(2))) - ((* *) (##core#inline "C_i_greater_or_equalp" #(1) #(2)))) - -(<= (#(procedure #:clean #:enforce #:foldable) <= (#!rest number) boolean) - (() '#t) - ((number) (let ((#(tmp) #(1))) '#t)) - ((fixnum fixnum) (chicken.fixnum#fx<= #(1) #(2))) - ((integer integer) (##core#inline "C_i_integer_less_or_equalp" #(1) #(2))) - ((float float) (##core#inline "C_flonum_less_or_equal_p" #(1) #(2))) - ((* *) (##core#inline "C_i_less_or_equalp" #(1) #(2)))) - -(quotient (#(procedure #:clean #:enforce #:foldable) quotient ((or integer float) (or integer float)) (or integer float)) - ;;XXX flonum/mixed case - ((float float) (float) +(scheme#rational? (#(procedure #:pure #:foldable) scheme#rational? (*) boolean) + (((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)))) + +(scheme#zero? (#(procedure #:clean #:enforce #:foldable) scheme#zero? (number) boolean) + ((integer) (scheme#eq? #(1) '0)) + (((or cplxnum ratnum)) (let ((#(tmp) #(1))) '#f)) + ((number) (##core#inline "C_u_i_zerop" #(1))) + ((*) (##core#inline "C_i_zerop" #(1)))) + +(scheme#odd? (#(procedure #:clean #:enforce #:foldable) scheme#odd? (number) boolean) + ((fixnum) (##core#inline "C_i_fixnumoddp" #(1))) + ((integer) (##core#inline "C_i_integer_oddp" #(1))) + ((*) (##core#inline "C_i_oddp" #(1)))) +(scheme#even? (#(procedure #:clean #:enforce #:foldable) scheme#even? (number) boolean) + ((fixnum) (##core#inline "C_i_fixnumevenp" #(1))) + ((integer) (##core#inline "C_i_integer_evenp" #(1))) + ((*) (##core#inline "C_i_evenp" #(1)))) + +(scheme#positive? (#(procedure #:clean #:enforce #:foldable) scheme#positive? (number) boolean) + ((fixnum) (##core#inline "C_i_fixnum_positivep" #(1))) + ((integer) (##core#inline "C_i_integer_positivep" #(1))) + ((*) (##core#inline "C_i_positivep" #(1)))) + +(scheme#negative? (#(procedure #:clean #:enforce #:foldable) scheme#negative? (number) boolean) + ((fixnum) (##core#inline "C_i_fixnum_negativep" #(1))) + ((integer) (##core#inline "C_i_integer_negativep" #(1))) + ((*) (##core#inline "C_i_negativep" #(1)))) + +(scheme#max (#(procedure #:clean #:enforce #:foldable) scheme#max (#!rest number) number) + ((fixnum fixnum) (chicken.fixnum#fxmax #(1) #(2))) + ((float float) (##core#inline "C_i_flonum_max" #(1) #(2)))) + +(scheme#min (#(procedure #:clean #:enforce #:foldable) scheme#min (#!rest number) number) + ((fixnum fixnum) (chicken.fixnum#fxmin #(1) #(2))) + ((float float) (##core#inline "C_i_flonum_min" #(1) #(2)))) + +(scheme#+ (#(procedure #:clean #:enforce #:foldable) scheme#+ (#!rest number) number) + (() (fixnum) '0) + ((fixnum) (fixnum) #(1)) + ((float) (float) #(1)) + ((integer) (integer) #(1)) + ((ratnum) (ratnum) #(1)) + ((cplxnum) (cplxnum) #(1)) + ((number) (number) #(1)) + ((float fixnum) (float) + (##core#inline_allocate + ("C_a_i_flonum_plus" 4) + #(1) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) + ((fixnum float) + (float) (##core#inline_allocate - ("C_a_i_flonum_actual_quotient_checked" 4) #(1) #(2))) + ("C_a_i_flonum_plus" 4) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) + #(2))) + ((float float) (float) + (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2))) ((fixnum fixnum) (integer) - (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 5) - #(1) #(2))) + (##core#inline_allocate ("C_a_i_fixnum_plus" 5) #(1) #(2))) ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) #(1) #(2))) - ((* *) (##core#inline_allocate ("C_s_a_i_quotient" 5) #(1) #(2)))) - -(remainder (#(procedure #:clean #:enforce #:foldable) remainder ((or integer float) (or integer float)) (or integer float)) - ((float float) (float) + (##core#inline_allocate ("C_s_a_u_i_integer_plus" 5) #(1) #(2))) + ((* *) (number) + (##core#inline_allocate ("C_s_a_i_plus" 29) #(1) #(2)))) + +(scheme#- (#(procedure #:clean #:enforce #:foldable) scheme#- (number #!rest number) number) + ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 5) #(1))) + ((integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) #(1))) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1))) + ((*) (*) (##core#inline_allocate ("C_s_a_i_negate" 29) #(1))) + ((float fixnum) (float) (##core#inline_allocate - ("C_a_i_flonum_remainder_checked" 4) #(1) #(2))) - ;;XXX flonum/mixed case - ((fixnum fixnum) (fixnum) - (##core#inline "C_i_fixnum_remainder_checked" #(1) #(2))) + ("C_a_i_flonum_difference" 4) + #(1) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) + ((fixnum float) (float) + (##core#inline_allocate + ("C_a_i_flonum_difference" 4) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) + #(2))) + ((float float) (float) + (##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) #(2))) + ((fixnum fixnum) (integer) + (##core#inline_allocate ("C_a_i_fixnum_difference" 5) #(1) #(2))) ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_remainder" 5) #(1) #(2))) - ((* *) (##core#inline_allocate ("C_s_a_i_remainder" 5) #(1) #(2)))) + (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) #(2))) + ((* *) (number) + (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) #(2)))) -(modulo (#(procedure #:clean #:enforce #:foldable) modulo ((or integer float) (or integer float)) (or integer float)) - ((float float) (float) +(scheme#* (#(procedure #:clean #:enforce #:foldable) scheme#* (#!rest number) number) + (() (fixnum) '1) + ((fixnum) (fixnum) #(1)) + ((float) (float) #(1)) + ((bignum) (bignum) #(1)) + ((integer) (integer) #(1)) + ((ratnum) (ratnum) #(1)) + ((cplxnum) (cplxnum) #(1)) + ((number) (number) #(1)) + ((float fixnum) (float) (##core#inline_allocate - ("C_a_i_flonum_modulo_checked" 4) #(1) #(2))) - ;;XXX flonum/mixed case - ((fixnum fixnum) (fixnum) - (##core#inline "C_fixnum_modulo" #(1) #(2))) + ("C_a_i_flonum_times" 4) + #(1) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) + ((fixnum float) (float) + (##core#inline_allocate + ("C_a_i_flonum_times" 4) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) + #(2))) + ((float float) (float) + (##core#inline_allocate ("C_a_i_flonum_times" 4) #(1) #(2))) + ((fixnum fixnum) (integer) + (##core#inline_allocate ("C_a_i_fixnum_times" 5) #(1) #(2))) ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_modulo" 5) #(1) #(2))) - ((* *) (##core#inline_allocate ("C_s_a_i_modulo" 5) #(1) #(2)))) + (##core#inline_allocate ("C_s_a_u_i_integer_times" 5) #(1) #(2))) + ((* *) (number) + (##core#inline_allocate ("C_s_a_i_times" 33) #(1) #(2)))) -(gcd (#(procedure #:clean #:enforce #:foldable) gcd (#!rest (or integer float)) (or integer float)) - (() '0) - ((fixnum fixnum) (fixnum) (chicken.fixnum#fxgcd #(1) #(2))) - ((float float) (float) (chicken.flonum#fpgcd #(1) #(2))) - ((integer integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_gcd" 5) #(1) #(2))) - ((* *) (##sys#gcd #(1) #(2)))) +(scheme#/ (#(procedure #:clean #:enforce #:foldable) scheme#/ (number #!rest number) number) + ((float fixnum) (float) + ;; This is the only checked one because the divisor is an exact value + (##core#inline_allocate + ("C_a_i_flonum_quotient_checked" 4) + #(1) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) + ((fixnum float) (float) + (##core#inline_allocate + ("C_a_i_flonum_quotient" 4) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) + #(2))) + ((float float) (float) + (##core#inline_allocate ("C_a_i_flonum_quotient" 4) #(1) #(2))) + ((integer integer) ((or integer ratnum)) + (##sys#/-2 #(1) #(2))) + ((* *) (number) + (##sys#/-2 #(1) #(2)))) + +(scheme#= (#(procedure #:clean #:enforce #:foldable) scheme#= (#!rest number) boolean) + (() '#t) + ((number) (let ((#(tmp) #(1))) '#t)) + ((fixnum fixnum) (scheme#eq? #(1) #(2))) + ((float float) (##core#inline "C_flonum_equalp" #(1) #(2))) + ((integer integer) (##core#inline "C_i_integer_equalp" #(1) #(2))) + ((* *) (##core#inline "C_i_nequalp" #(1) #(2)))) + +(scheme#> (#(procedure #:clean #:enforce #:foldable) scheme#> (#!rest number) boolean) + (() '#t) + ((number) (let ((#(tmp) #(1))) '#t)) + ((fixnum fixnum) (chicken.fixnum#fx> #(1) #(2))) + ((float float) (##core#inline "C_flonum_greaterp" #(1) #(2))) + ((integer integer) (##core#inline "C_i_integer_greaterp" #(1) #(2))) + ((* *) (##core#inline "C_i_greaterp" #(1) #(2)))) + +(scheme#< (#(procedure #:clean #:enforce #:foldable) scheme#< (#!rest number) boolean) + (() '#t) + ((number) (let ((#(tmp) #(1))) '#t)) + ((fixnum fixnum) (chicken.fixnum#fx< #(1) #(2))) + ((integer integer) (##core#inline "C_i_integer_lessp" #(1) #(2))) + ((float float) (##core#inline "C_flonum_lessp" #(1) #(2))) + ((* *) (##core#inline "C_i_lessp" #(1) #(2)))) + +(scheme#>= (#(procedure #:clean #:enforce #:foldable) scheme#>= (#!rest number) boolean) + (() '#t) + ((number) (let ((#(tmp) #(1))) '#t)) + ((fixnum fixnum) (chicken.fixnum#fx>= #(1) #(2))) + ((integer integer) (##core#inline "C_i_integer_greater_or_equalp" #(1) #(2))) + ((float float) (##core#inline "C_flonum_greater_or_equal_p" #(1) #(2))) + ((* *) (##core#inline "C_i_greater_or_equalp" #(1) #(2)))) + +(scheme#<= (#(procedure #:clean #:enforce #:foldable) scheme#<= (#!rest number) boolean) + (() '#t) + ((number) (let ((#(tmp) #(1))) '#t)) + ((fixnum fixnum) (chicken.fixnum#fx<= #(1) #(2))) + ((integer integer) (##core#inline "C_i_integer_less_or_equalp" #(1) #(2))) + ((float float) (##core#inline "C_flonum_less_or_equal_p" #(1) #(2))) + ((* *) (##core#inline "C_i_less_or_equalp" #(1) #(2)))) + +(scheme#quotient (#(procedure #:clean #:enforce #:foldable) scheme#quotient ((or integer float) (or integer float)) (or integer float)) + ;;XXX flonum/mixed case + ((float float) (float) + (##core#inline_allocate + ("C_a_i_flonum_actual_quotient_checked" 4) #(1) #(2))) + ((fixnum fixnum) (integer) + (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 5) + #(1) #(2))) + ((integer integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) #(1) #(2))) + ((* *) (##core#inline_allocate ("C_s_a_i_quotient" 5) #(1) #(2)))) + +(scheme#remainder (#(procedure #:clean #:enforce #:foldable) scheme#remainder ((or integer float) (or integer float)) (or integer float)) + ((float float) (float) + (##core#inline_allocate + ("C_a_i_flonum_remainder_checked" 4) #(1) #(2))) + ;;XXX flonum/mixed case + ((fixnum fixnum) (fixnum) + (##core#inline "C_i_fixnum_remainder_checked" #(1) #(2))) + ((integer integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_remainder" 5) #(1) #(2))) + ((* *) (##core#inline_allocate ("C_s_a_i_remainder" 5) #(1) #(2)))) + +(scheme#modulo (#(procedure #:clean #:enforce #:foldable) scheme#modulo ((or integer float) (or integer float)) (or integer float)) + ((float float) (float) + (##core#inline_allocate + ("C_a_i_flonum_modulo_checked" 4) #(1) #(2))) + ;;XXX flonum/mixed case + ((fixnum fixnum) (fixnum) + (##core#inline "C_fixnum_modulo" #(1) #(2))) + ((integer integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_modulo" 5) #(1) #(2))) + ((* *) (##core#inline_allocate ("C_s_a_i_modulo" 5) #(1) #(2)))) + +(scheme#gcd (#(procedure #:clean #:enforce #:foldable) scheme#gcd (#!rest (or integer float)) (or integer float)) + (() '0) + ((fixnum fixnum) (fixnum) (chicken.fixnum#fxgcd #(1) #(2))) + ((float float) (float) (chicken.flonum#fpgcd #(1) #(2))) + ((integer integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_gcd" 5) #(1) #(2))) + ((* *) (##sys#gcd #(1) #(2)))) (##sys#gcd (#(procedure #:clean #:enforce #:foldable) ##sys#gcd (number number) number)) -(lcm (#(procedure #:clean #:enforce #:foldable) lcm (#!rest number) number) - (() '1) - ((* *) (##sys#lcm #(1) #(2)))) +(scheme#lcm (#(procedure #:clean #:enforce #:foldable) scheme#lcm (#!rest number) number) + (() '1) + ((* *) (##sys#lcm #(1) #(2)))) (##sys#lcm (#(procedure #:clean #:enforce #:foldable) ##sys#lcm (number number) number)) -(abs (#(procedure #:clean #:enforce #:foldable) abs (number) number) - ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 5) #(1))) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))) - ((integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_abs" 5) #(1))) - ((*) (*) - (##core#inline_allocate ("C_s_a_i_abs" 7) #(1)))) - -(floor (#(procedure #:clean #:enforce #:foldable) floor ((or integer ratnum float)) (or integer ratnum float)) - ((fixnum) (fixnum) #(1)) - ((integer) (integer) #(1)) - ((float) (float) - (##core#inline_allocate ("C_a_i_flonum_floor" 4) #(1)))) - -(ceiling (#(procedure #:clean #:enforce #:foldable) ceiling ((or integer ratnum float)) (or integer ratnum float)) - ((fixnum) (fixnum) #(1)) - ((integer) (integer) #(1)) - ((float) (float) - (##core#inline_allocate ("C_a_i_flonum_ceiling" 4) #(1)))) - -(truncate (#(procedure #:clean #:enforce #:foldable) truncate ((or integer ratnum float)) (or integer ratnum float)) - ((fixnum) (fixnum) #(1)) - ((integer) (integer) #(1)) - ((float) (float) - (##core#inline_allocate ("C_a_i_flonum_truncate" 4) #(1)))) - -(round (#(procedure #:clean #:enforce #:foldable) round ((or integer ratnum float)) (or integer ratnum float)) - ((fixnum) (fixnum) #(1)) - ((integer) (integer) #(1)) - ((float) (float) - (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) #(1)))) - -(exact->inexact (#(procedure #:clean #:enforce #:foldable) exact->inexact (number) (or float cplxnum)) - ((float) (float) #(1)) - ((fixnum) (float) (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1))) - ((number) (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) #(1)))) - -(inexact->exact (#(procedure #:clean #:enforce #:foldable) inexact->exact (number) (or integer ratnum)) +(scheme#abs (#(procedure #:clean #:enforce #:foldable) scheme#abs (number) number) + ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 5) #(1))) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))) + ((integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_abs" 5) #(1))) + ((*) (*) + (##core#inline_allocate ("C_s_a_i_abs" 7) #(1)))) + +(scheme#floor (#(procedure #:clean #:enforce #:foldable) scheme#floor ((or integer ratnum float)) (or integer ratnum float)) + ((fixnum) (fixnum) #(1)) + ((integer) (integer) #(1)) + ((float) (float) + (##core#inline_allocate ("C_a_i_flonum_floor" 4) #(1)))) + +(scheme#ceiling (#(procedure #:clean #:enforce #:foldable) scheme#ceiling ((or integer ratnum float)) (or integer ratnum float)) ((fixnum) (fixnum) #(1)) ((integer) (integer) #(1)) - ((ratnum) (ratnum) #(1)) - (((or integer ratnum)) #(1))) - -(exp (#(procedure #:clean #:enforce #:foldable) exp (number) (or float cplxnum)) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_exp" 4) #(1)))) - -(log (#(procedure #:clean #:enforce #:foldable) log (number) (or float cplxnum)) - ;; Unfortunately this doesn't work when the argument is negative - ;;((float) (float) (##core#inline_allocate ("C_a_i_flonum_log" 4) #(1))) - ((*) (##sys#log-1 #(1)))) - -(expt (#(procedure #:clean #:enforce #:foldable) expt (number number) number) - ;; This breaks in some extreme edge cases... Worth disabling? - #;((float float) (float) - (##core#inline_allocate ("C_a_i_flonum_expt" 4) #(1) #(2))) - #;((float fixnum) (float) - (##core#inline_allocate ("C_a_i_flonum_expt" 4) - #(1) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) - #;((fixnum float) (float) - (##core#inline_allocate ("C_a_i_flonum_expt" 4) - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) - #(2)))) - -(sqrt (#(procedure #:clean #:enforce #:foldable) sqrt (number) number) - ;; Unfortunately this doesn't work when the argument is negative - #;((float) (float) (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) #(1)))) - -(sin (#(procedure #:clean #:enforce #:foldable) sin (number) (or float cplxnum)) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_sin" 4) #(1)))) - -(cos (#(procedure #:clean #:enforce #:foldable) cos (number) (or float cplxnum)) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_cos" 4) #(1)))) - -(tan (#(procedure #:clean #:enforce #:foldable) tan (number) (or float cplxnum)) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_tan" 4) #(1)))) - -(asin (#(procedure #:clean #:enforce #:foldable) asin (number) (or float cplxnum)) - ;; Unfortunately this doesn't work when the number is > 1.0 (returns compnum) + ((float) (float) + (##core#inline_allocate ("C_a_i_flonum_ceiling" 4) #(1)))) + +(scheme#truncate (#(procedure #:clean #:enforce #:foldable) scheme#truncate ((or integer ratnum float)) (or integer ratnum float)) + ((fixnum) (fixnum) #(1)) + ((integer) (integer) #(1)) + ((float) (float) + (##core#inline_allocate ("C_a_i_flonum_truncate" 4) #(1)))) + +(scheme#round (#(procedure #:clean #:enforce #:foldable) scheme#round ((or integer ratnum float)) (or integer ratnum float)) + ((fixnum) (fixnum) #(1)) + ((integer) (integer) #(1)) + ((float) (float) + (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) #(1)))) + +(scheme#exact->inexact (#(procedure #:clean #:enforce #:foldable) scheme#exact->inexact (number) (or float cplxnum)) + ((float) (float) #(1)) + ((fixnum) (float) (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1))) + ((number) (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) #(1)))) + +(scheme#inexact->exact (#(procedure #:clean #:enforce #:foldable) scheme#inexact->exact (number) (or integer ratnum)) + ((fixnum) (fixnum) #(1)) + ((integer) (integer) #(1)) + ((ratnum) (ratnum) #(1)) + (((or integer ratnum)) #(1))) + +(scheme#exp (#(procedure #:clean #:enforce #:foldable) scheme#exp (number) (or float cplxnum)) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_exp" 4) #(1)))) + +(scheme#log (#(procedure #:clean #:enforce #:foldable) scheme#log (number) (or float cplxnum)) + ;; Unfortunately this doesn't work when the argument is negative + ;;((float) (float) (##core#inline_allocate ("C_a_i_flonum_log" 4) #(1))) + ((*) (##sys#log-1 #(1)))) + +(scheme#expt (#(procedure #:clean #:enforce #:foldable) scheme#expt (number number) number) + ;; This breaks in some extreme edge cases... Worth disabling? + #;((float float) (float) + (##core#inline_allocate ("C_a_i_flonum_expt" 4) #(1) #(2))) + #;((float fixnum) (float) + (##core#inline_allocate ("C_a_i_flonum_expt" 4) + #(1) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2)))) + #;((fixnum float) (float) + (##core#inline_allocate ("C_a_i_flonum_expt" 4) + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)) + #(2)))) + +(scheme#sqrt (#(procedure #:clean #:enforce #:foldable) scheme#sqrt (number) number) + ;; Unfortunately this doesn't work when the argument is negative + #;((float) (float) (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) #(1)))) + +(scheme#sin (#(procedure #:clean #:enforce #:foldable) scheme#sin (number) (or float cplxnum)) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_sin" 4) #(1)))) + +(scheme#cos (#(procedure #:clean #:enforce #:foldable) scheme#cos (number) (or float cplxnum)) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_cos" 4) #(1)))) + +(scheme#tan (#(procedure #:clean #:enforce #:foldable) scheme#tan (number) (or float cplxnum)) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_tan" 4) #(1)))) + +(scheme#asin (#(procedure #:clean #:enforce #:foldable) scheme#asin (number) (or float cplxnum)) + ;; Unfortunately this doesn't work when the number is > 1.0 (returns compnum) #;((float) (float) (##core#inline_allocate ("C_a_i_flonum_acos" 4) #(1)))) -(acos (#(procedure #:clean #:enforce #:foldable) acos (number) (or float cplxnum)) - ;; Unfortunately this doesn't work when the number is > 1.0 (returns compnum) +(scheme#acos (#(procedure #:clean #:enforce #:foldable) scheme#acos (number) (or float cplxnum)) + ;; Unfortunately this doesn't work when the number is > 1.0 (returns compnum) #;((float) (float) (##core#inline_allocate ("C_a_i_flonum_acos" 4) #(1)))) -(atan (#(procedure #:clean #:enforce #:foldable) atan (number #!optional number) (or float cplxnum)) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_atan" 4) #(1))) - ((float float) (float) - (##core#inline_allocate ("C_a_i_flonum_atan2" 4) #(1) #(2)))) - -(number->string (#(procedure #:clean #:enforce) number->string (number #!optional fixnum) string) - ((fixnum fixnum) (##sys#fixnum->string #(1) #(2))) - ((fixnum) (##sys#fixnum->string #(1) '10)) - ((integer fixnum) (##sys#integer->string #(1) #(2))) - ((integer) (##sys#integer->string #(1) '10)) - ((float fixnum) (##sys#flonum->string #(1) #(2))) - ((float) (##sys#flonum->string #(1) '10)) - ((* *) (##sys#number->string #(1) #(2))) - ((*) (##sys#number->string #(1) '10))) +(scheme#atan (#(procedure #:clean #:enforce #:foldable) scheme#atan (number #!optional number) (or float cplxnum)) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_atan" 4) #(1))) + ((float float) (float) + (##core#inline_allocate ("C_a_i_flonum_atan2" 4) #(1) #(2)))) + +(scheme#number->string (#(procedure #:clean #:enforce) scheme#number->string (number #!optional fixnum) string) + ((fixnum fixnum) (##sys#fixnum->string #(1) #(2))) + ((fixnum) (##sys#fixnum->string #(1) '10)) + ((integer fixnum) (##sys#integer->string #(1) #(2))) + ((integer) (##sys#integer->string #(1) '10)) + ((float fixnum) (##sys#flonum->string #(1) #(2))) + ((float) (##sys#flonum->string #(1) '10)) + ((* *) (##sys#number->string #(1) #(2))) + ((*) (##sys#number->string #(1) '10))) (##sys#fixnum->string (#(procedure #:clean #:enforce) ##sys#fixnum->string (fixnum fixnum) string)) (##sys#integer->string (#(procedure #:clean #:enforce) ##sys#integer->string (integer fixnum) string)) (##sys#flonum->string (#(procedure #:clean #:enforce) ##sys#flonum->string (float fixnum) string)) -(string->number (#(procedure #:clean #:enforce #:foldable) string->number (string #!optional fixnum) - (or number false))) +(scheme#string->number (#(procedure #:clean #:enforce #:foldable) scheme#string->number (string #!optional fixnum) + (or number false))) -(char? (#(procedure #:pure #:predicate char) char? (*) boolean)) +(scheme#char? (#(procedure #:pure #:predicate char) scheme#char? (*) boolean)) ;; safe rewrites are already done by the optimizer -(char=? (#(procedure #:clean #:enforce #:foldable) char=? (char char) boolean) - ((char char) (##core#inline "C_u_i_char_equalp" #(1) #(2)))) -(char>? (#(procedure #:clean #:enforce #:foldable) char>? (char char) boolean) - ((char char) (##core#inline "C_u_i_char_greaterp" #(1) #(2)))) -(char=? (#(procedure #:clean #:enforce #:foldable) char>=? (char char) boolean) - ((char char) (##core#inline "C_u_i_char_greater_or_equal_p" #(1) #(2)))) -(char<=? (#(procedure #:clean #:enforce #:foldable) char<=? (char char) boolean) - ((char char) (##core#inline "C_u_i_char_less_or_equal_p" #(1) #(2)))) - -(char-ci=? (#(procedure #:clean #:enforce #:foldable) char-ci=? (char char) boolean)) -(char-ci? (#(procedure #:clean #:enforce #:foldable) char-ci>? (char char) boolean)) -(char-ci>=? (#(procedure #:clean #:enforce #:foldable) char-ci>=? (char char) boolean)) -(char-ci<=? (#(procedure #:clean #:enforce #:foldable) char-ci<=? (char char) boolean)) -(char-alphabetic? (#(procedure #:clean #:enforce #:foldable) char-alphabetic? (char) boolean)) -(char-whitespace? (#(procedure #:clean #:enforce #:foldable) char-whitespace? (char) boolean)) -(char-numeric? (#(procedure #:clean #:enforce #:foldable) char-numeric? (char) boolean)) -(char-upper-case? (#(procedure #:clean #:enforce #:foldable) char-upper-case? (char) boolean)) -(char-lower-case? (#(procedure #:clean #:enforce #:foldable) char-lower-case? (char) boolean)) -(char-upcase (#(procedure #:clean #:enforce #:foldable) char-upcase (char) char)) -(char-downcase (#(procedure #:clean #:enforce #:foldable) char-downcase (char) char)) - -(char->integer (#(procedure #:clean #:enforce #:foldable) char->integer (char) fixnum)) -(integer->char (#(procedure #:clean #:enforce #:foldable) integer->char (fixnum) char)) - -(string? (#(procedure #:pure #:predicate string) string? (*) boolean)) - -(string=? (#(procedure #:clean #:enforce #:foldable) string=? (string string) boolean) - ((string string) (##core#inline "C_u_i_string_equal_p" #(1) #(2)))) - -(string>? (#(procedure #:clean #:enforce #:foldable) string>? (string string) boolean)) -(string=? (#(procedure #:clean #:enforce #:foldable) string>=? (string string) boolean)) -(string<=? (#(procedure #:clean #:enforce #:foldable) string<=? (string string) boolean)) -(string-ci=? (#(procedure #:clean #:enforce #:foldable) string-ci=? (string string) boolean)) -(string-ci? (#(procedure #:clean #:enforce #:foldable) string-ci>? (string string) boolean)) -(string-ci>=? (#(procedure #:clean #:enforce #:foldable) string-ci>=? (string string) boolean)) -(string-ci<=? (#(procedure #:clean #:enforce #:foldable) string-ci<=? (string string) boolean)) - -(make-string (#(procedure #:clean #:enforce) make-string (fixnum #!optional char) string) - ((fixnum char) (##sys#make-string #(1) #(2))) - ((fixnum) (##sys#make-string #(1) '#\space))) - -(string-length (#(procedure #:clean #:enforce #:foldable) string-length (string) fixnum) +(scheme#char=? (#(procedure #:clean #:enforce #:foldable) scheme#char=? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_equalp" #(1) #(2)))) +(scheme#char>? (#(procedure #:clean #:enforce #:foldable) scheme#char>? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_greaterp" #(1) #(2)))) +(scheme#char=? (#(procedure #:clean #:enforce #:foldable) scheme#char>=? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_greater_or_equal_p" #(1) #(2)))) +(scheme#char<=? (#(procedure #:clean #:enforce #:foldable) scheme#char<=? (char char) boolean) + ((char char) (##core#inline "C_u_i_char_less_or_equal_p" #(1) #(2)))) + +(scheme#char-ci=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci=? (char char) boolean)) +(scheme#char-ci? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci>? (char char) boolean)) +(scheme#char-ci>=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci>=? (char char) boolean)) +(scheme#char-ci<=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci<=? (char char) boolean)) +(scheme#char-alphabetic? (#(procedure #:clean #:enforce #:foldable) scheme#char-alphabetic? (char) boolean)) +(scheme#char-whitespace? (#(procedure #:clean #:enforce #:foldable) scheme#char-whitespace? (char) boolean)) +(scheme#char-numeric? (#(procedure #:clean #:enforce #:foldable) scheme#char-numeric? (char) boolean)) +(scheme#char-upper-case? (#(procedure #:clean #:enforce #:foldable) scheme#char-upper-case? (char) boolean)) +(scheme#char-lower-case? (#(procedure #:clean #:enforce #:foldable) scheme#char-lower-case? (char) boolean)) +(scheme#char-upcase (#(procedure #:clean #:enforce #:foldable) scheme#char-upcase (char) char)) +(scheme#char-downcase (#(procedure #:clean #:enforce #:foldable) scheme#char-downcase (char) char)) + +(scheme#char->integer (#(procedure #:clean #:enforce #:foldable) scheme#char->integer (char) fixnum)) +(scheme#integer->char (#(procedure #:clean #:enforce #:foldable) scheme#integer->char (fixnum) char)) + +(scheme#string? (#(procedure #:pure #:predicate string) scheme#string? (*) boolean)) + +(scheme#string=? (#(procedure #:clean #:enforce #:foldable) scheme#string=? (string string) boolean) + ((string string) (##core#inline "C_u_i_string_equal_p" #(1) #(2)))) + +(scheme#string>? (#(procedure #:clean #:enforce #:foldable) scheme#string>? (string string) boolean)) +(scheme#string=? (#(procedure #:clean #:enforce #:foldable) scheme#string>=? (string string) boolean)) +(scheme#string<=? (#(procedure #:clean #:enforce #:foldable) scheme#string<=? (string string) boolean)) +(scheme#string-ci=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci=? (string string) boolean)) +(scheme#string-ci? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci>? (string string) boolean)) +(scheme#string-ci>=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci>=? (string string) boolean)) +(scheme#string-ci<=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci<=? (string string) boolean)) + +(scheme#make-string (#(procedure #:clean #:enforce) scheme#make-string (fixnum #!optional char) string) + ((fixnum char) (##sys#make-string #(1) #(2))) + ((fixnum) (##sys#make-string #(1) '#\space))) + +(scheme#string-length (#(procedure #:clean #:enforce #:foldable) scheme#string-length (string) fixnum) ((string) (##sys#size #(1)))) -(string-ref (#(procedure #:clean #:enforce #:foldable) string-ref (string fixnum) char) - ((string fixnum) (##core#inline "C_i_string_ref" #(1) #(2)))) +(scheme#string-ref (#(procedure #:clean #:enforce #:foldable) scheme#string-ref (string fixnum) char) + ((string fixnum) (##core#inline "C_i_string_ref" #(1) #(2)))) -(string-set! (#(procedure #:enforce) string-set! (string fixnum char) undefined) - ((string fixnum char) (##core#inline "C_i_string_set" #(1) #(2) #(3)))) +(scheme#string-set! (#(procedure #:enforce) scheme#string-set! (string fixnum char) undefined) + ((string fixnum char) (##core#inline "C_i_string_set" #(1) #(2) #(3)))) -(string-append (#(procedure #:clean #:enforce) string-append (#!rest string) string) - ((string string) (##sys#string-append #(1) #(2)))) +(scheme#string-append (#(procedure #:clean #:enforce) scheme#string-append (#!rest string) string) + ((string string) (##sys#string-append #(1) #(2)))) -(string-copy (#(procedure #:clean #:enforce) string-copy (string) string)) +(scheme#string-copy (#(procedure #:clean #:enforce) scheme#string-copy (string) string)) -(string->list (#(procedure #:clean #:enforce) string->list (string) (list-of char))) -(list->string (#(procedure #:clean #:enforce) list->string ((list-of char)) string)) -(substring (#(procedure #:clean #:enforce) substring (string fixnum #!optional fixnum) string)) -(string-fill! (#(procedure #:enforce) string-fill! (string char) string)) -(string (#(procedure #:clean #:enforce) string (#!rest char) string)) +(scheme#string->list (#(procedure #:clean #:enforce) scheme#string->list (string) (list-of char))) +(scheme#list->string (#(procedure #:clean #:enforce) scheme#list->string ((list-of char)) string)) +(scheme#substring (#(procedure #:clean #:enforce) scheme#substring (string fixnum #!optional fixnum) string)) +(scheme#string-fill! (#(procedure #:enforce) scheme#string-fill! (string char) string)) +(scheme#string (#(procedure #:clean #:enforce) scheme#string (#!rest char) string)) -(vector? (#(procedure #:pure #:predicate vector) vector? (*) boolean)) +(scheme#vector? (#(procedure #:pure #:predicate vector) scheme#vector? (*) boolean)) ;; special-cased (see scrutinizer.scm) -(make-vector (forall (a) (#(procedure #:clean #:enforce) make-vector (fixnum #!optional a) - (vector-of a)))) +(scheme#make-vector (forall (a) (#(procedure #:clean #:enforce) scheme#make-vector (fixnum #!optional a) + (vector-of a)))) ;; these are special cased (see scrutinizer.scm) -(vector-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) vector-ref ((vector-of a) fixnum) a))) +(scheme#vector-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) scheme#vector-ref ((vector-of a) fixnum) a))) (##sys#vector-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) ##sys#vector-ref ((vector-of a) fixnum) a))) ;; special-cased (see scrutinizer.scm) -(vector-set! (#(procedure #:enforce) vector-set! (vector fixnum *) undefined)) +(scheme#vector-set! (#(procedure #:enforce) scheme#vector-set! (vector fixnum *) undefined)) ;; special cased (see scrutinizer.scm) -(vector (#(procedure #:pure) vector (#!rest) vector)) +(scheme#vector (#(procedure #:pure) scheme#vector (#!rest) vector)) (##sys#vector (#(procedure #:pure) ##sys#vector (#!rest) vector)) -(vector-length (#(procedure #:clean #:enforce #:foldable) vector-length (vector) fixnum) - ((vector) (##sys#size #(1)))) +(scheme#vector-length (#(procedure #:clean #:enforce #:foldable) scheme#vector-length (vector) fixnum) + ((vector) (##sys#size #(1)))) (##sys#vector-length (#(procedure #:clean #:enforce #:foldable) ##sys#vector-length (vector) fixnum) ((vector) (##sys#size #(1)))) -(vector->list (forall (a) (#(procedure #:clean #:enforce) vector->list ((vector-of a)) (list-of a)))) +(scheme#vector->list (forall (a) (#(procedure #:clean #:enforce) scheme#vector->list ((vector-of a)) (list-of a)))) (##sys#vector->list (forall (a) (#(procedure #:clean #:enforce) ##sys#vector->list ((vector-of a)) (list-of a)))) -(list->vector (forall (a) (#(procedure #:clean #:enforce) list->vector ((list-of a)) (vector-of a)))) +(scheme#list->vector (forall (a) (#(procedure #:clean #:enforce) scheme#list->vector ((list-of a)) (vector-of a)))) (##sys#list->vector (forall (a) (#(procedure #:clean #:enforce) ##sys#list->vector ((list-of a)) (vector-of a)))) -(procedure? (#(procedure #:pure #:predicate procedure) procedure? (*) boolean)) +(scheme#procedure? (#(procedure #:pure #:predicate procedure) scheme#procedure? (*) boolean)) -(map (forall (a b) (#(procedure #:enforce) map ((procedure (a #!rest) b) (list-of a) #!rest list) (list-of b)))) +(scheme#map (forall (a b) (#(procedure #:enforce) scheme#map ((procedure (a #!rest) b) (list-of a) #!rest list) (list-of b)))) -(for-each - (forall (a) (#(procedure #:enforce) for-each ((procedure (a #!rest) . *) (list-of a) #!rest list) undefined))) +(scheme#for-each + (forall (a) (#(procedure #:enforce) scheme#for-each ((procedure (a #!rest) . *) (list-of a) #!rest list) undefined))) -(apply (#(procedure #:enforce) apply (procedure #!rest) . *)) +(scheme#apply (#(procedure #:enforce) scheme#apply (procedure #!rest) . *)) (##sys#apply (#(procedure #:enforce) ##sys#apply (procedure #!rest) . *)) -(force (procedure force (*) . *) - (((not (struct promise))) #(1))) +(scheme#force (procedure scheme#force (*) . *) + (((not (struct promise))) #(1))) -(call-with-current-continuation - (#(procedure #:enforce) call-with-current-continuation ((procedure (procedure) . *)) . *)) +(scheme#call-with-current-continuation + (#(procedure #:enforce) scheme#call-with-current-continuation + ((procedure (procedure) . *)) . *)) -(input-port? (#(procedure #:pure #:predicate (refine (input) port)) input-port? (*) boolean)) -(output-port? (#(procedure #:pure #:predicate (refine (output) port)) output-port? (*) boolean)) +(scheme#input-port? (#(procedure #:pure #:predicate (refine (input) port)) scheme#input-port? (*) boolean)) +(scheme#output-port? (#(procedure #:pure #:predicate (refine (output) port)) scheme#output-port? (*) boolean)) -(current-input-port - (#(procedure #:clean #:enforce) current-input-port (#!optional input-port boolean boolean) input-port) +(scheme#current-input-port + (#(procedure #:clean #:enforce) scheme#current-input-port + (#!optional input-port boolean boolean) input-port) (() ##sys#standard-input) (((refine (input) port)) (let ((#(tmp1) #(1))) (let ((#(tmp2) (set! ##sys#standard-input #(tmp1)))) #(tmp1))))) -(current-output-port - (#(procedure #:clean #:enforce) current-output-port (#!optional output-port boolean boolean) output-port) +(scheme#current-output-port + (#(procedure #:clean #:enforce) scheme#current-output-port + (#!optional output-port boolean boolean) output-port) (() ##sys#standard-output) (((refine (output) port)) (let ((#(tmp1) #(1))) (let ((#(tmp2) (set! ##sys#standard-output #(tmp1)))) #(tmp1))))) -(call-with-input-file - (procedure call-with-input-file (string (procedure (input-port) . *) #!rest) . *)) +(scheme#call-with-input-file + (procedure scheme#call-with-input-file + (string (procedure (input-port) . *) #!rest) . *)) -(call-with-output-file - (procedure call-with-output-file (string (procedure (output-port) . *) #!rest) . *)) +(scheme#call-with-output-file + (procedure scheme#call-with-output-file + (string (procedure (output-port) . *) #!rest) . *)) -(open-input-file (#(procedure #:clean #:enforce) open-input-file (string #!rest symbol) input-port)) -(open-output-file (#(procedure #:clean #:enforce) open-output-file (string #!rest symbol) output-port)) -(close-input-port (#(procedure #:enforce) close-input-port (input-port) undefined)) -(close-output-port (#(procedure #:enforce) close-output-port (output-port) undefined)) +(scheme#open-input-file (#(procedure #:clean #:enforce) scheme#open-input-file (string #!rest symbol) input-port)) +(scheme#open-output-file (#(procedure #:clean #:enforce) scheme#open-output-file (string #!rest symbol) output-port)) +(scheme#close-input-port (#(procedure #:enforce) scheme#close-input-port (input-port) undefined)) +(scheme#close-output-port (#(procedure #:enforce) scheme#close-output-port (output-port) undefined)) (input-port-open? (#(procedure #:enforce) input-port-open? (input-port) boolean)) (output-port-open? (#(procedure #:enforce) output-port-open? (output-port) boolean)) -(read (#(procedure #:enforce) read (#!optional input-port) *)) +(scheme#read (#(procedure #:enforce) scheme#read (#!optional input-port) *)) -(eof-object? (#(procedure #:pure #:predicate eof) eof-object? (*) boolean)) +(scheme#eof-object? (#(procedure #:pure #:predicate eof) scheme#eof-object? (*) boolean)) -(read-char (#(procedure #:enforce) read-char (#!optional input-port) (or eof char))) -(peek-char (#(procedure #:enforce) peek-char (#!optional input-port) (or eof char))) +(scheme#read-char (#(procedure #:enforce) scheme#read-char (#!optional input-port) (or eof char))) +(scheme#peek-char (#(procedure #:enforce) scheme#peek-char (#!optional input-port) (or eof char))) -(write (#(procedure #:enforce) write (* #!optional output-port) undefined)) -(display (#(procedure #:enforce) display (* #!optional output-port) undefined)) -(write-char (#(procedure #:enforce) write-char (char #!optional output-port) undefined)) +(scheme#write (#(procedure #:enforce) scheme#write (* #!optional output-port) undefined)) +(scheme#display (#(procedure #:enforce) scheme#display (* #!optional output-port) undefined)) +(scheme#write-char (#(procedure #:enforce) scheme#write-char (char #!optional output-port) undefined)) ;;XXX Yes, that would be nice, but the output-port may be closed #;(##sys#write-char-0 @@ -754,21 +755,24 @@ (let ((#(tmp) #(1))) ((##sys#slot (##sys#slot #(tmp) '2) '2) #(tmp) #(2))))) -(newline (#(procedure #:enforce) newline (#!optional output-port) undefined)) +(scheme#newline (#(procedure #:enforce) scheme#newline (#!optional output-port) undefined)) -(with-input-from-file - (#(procedure #:enforce) with-input-from-file (string (procedure () . *) #!rest symbol) . *)) +(scheme#with-input-from-file + (#(procedure #:enforce) scheme#with-input-from-file (string (procedure () . *) #!rest symbol) . *)) -(with-output-to-file - (#(procedure #:enforce) with-output-to-file (string (procedure () . *) #!rest symbol) . *)) +(scheme#with-output-to-file + (#(procedure #:enforce) scheme#with-output-to-file + (string (procedure () . *) #!rest symbol) . *)) -(dynamic-wind - (#(procedure #:enforce) dynamic-wind ((procedure () . *) (procedure () . *) (procedure () . *)) . *)) +(scheme#dynamic-wind + (#(procedure #:enforce) scheme#dynamic-wind + ((procedure () . *) (procedure () . *) (procedure () . *)) . *)) -(values (#(procedure #:clean) values (#!rest values) . *)) +(scheme#values (#(procedure #:clean) scheme#values (#!rest values) . *)) (##sys#values (#(procedure #:clean) ##sys#values (#!rest values) . *)) -(call-with-values (#(procedure #:enforce) call-with-values ((procedure () . *) procedure) . *) +(scheme#call-with-values (#(procedure #:enforce) scheme#call-with-values + ((procedure () . *) procedure) . *) (((procedure () *) *) (let ((#(tmp1) #(1))) (let ((#(tmp2) #(2))) (#(tmp2) (#(tmp1))))))) @@ -779,46 +783,46 @@ (let ((#(tmp2) #(2))) (#(tmp2) (#(tmp1))))))) -(char-ready? (#(procedure #:enforce) char-ready? (#!optional input-port) boolean)) +(scheme#char-ready? (#(procedure #:enforce) scheme#char-ready? (#!optional input-port) boolean)) -(real-part (#(procedure #:clean #:enforce #:foldable) real-part (number) (or integer float ratnum)) +(scheme#real-part (#(procedure #:clean #:enforce #:foldable) scheme#real-part (number) (or integer float ratnum)) (((or fixnum float bignum ratnum)) #(1)) ((cplxnum) (##core#inline "C_u_i_cplxnum_real" #(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) (##core#inline "C_u_i_cplxnum_imag" #(1)))) - -(magnitude (#(procedure #:clean #:enforce #:foldable) magnitude (number) number) - ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 5) #(1))) - ((integer) (##core#inline_allocate ("C_s_a_u_i_integer_abs" 5) #(1))) - ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))) - (((or fixnum float bignum ratnum)) - (##core#inline_allocate ("C_s_a_i_abs" 7) #(1)))) - -(angle (#(procedure #:clean #:enforce #:foldable) angle (number) float) - ((float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) '0.0 #(1))) - ((fixnum) (##core#inline_allocate - ("C_a_i_flonum_atan2" 4) - '0.0 - (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)))) - ((cplxnum) - (let ((#(tmp) #(1))) - (##core#inline_allocate - ("C_a_i_flonum_atan2" 4) - (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) - (##core#inline "C_u_i_cplxnum_imag" #(tmp))) - (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) - (##core#inline "C_u_i_cplxnum_real" #(tmp))))))) - -(numerator (#(procedure #:clean #:enforce #:foldable) numerator ((or float integer ratnum)) (or float integer)) - ((fixnum) (fixnum) #(1)) - ((bignum) (bignum) #(1)) - ((integer) (integer) #(1)) - ((ratnum) (integer) (##core#inline "C_u_i_ratnum_num" #(1)))) - -(denominator (#(procedure #:clean #:enforce #:foldable) denominator ((or float integer ratnum)) (or float integer)) +(scheme#imag-part (#(procedure #:clean #:enforce #:foldable) scheme#imag-part (number) (or integer float ratnum)) + (((or fixnum bignum ratnum)) (let ((#(tmp) #(1))) '0)) + ((float) (let ((#(tmp) #(1))) '0.0)) + ((cplxnum) (##core#inline "C_u_i_cplxnum_imag" #(1)))) + +(scheme#magnitude (#(procedure #:clean #:enforce #:foldable) scheme#magnitude (number) number) + ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 5) #(1))) + ((integer) (##core#inline_allocate ("C_s_a_u_i_integer_abs" 5) #(1))) + ((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1))) + (((or fixnum float bignum ratnum)) + (##core#inline_allocate ("C_s_a_i_abs" 7) #(1)))) + +(scheme#angle (#(procedure #:clean #:enforce #:foldable) scheme#angle (number) float) + ((float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) '0.0 #(1))) + ((fixnum) (##core#inline_allocate + ("C_a_i_flonum_atan2" 4) + '0.0 + (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(1)))) + ((cplxnum) + (let ((#(tmp) #(1))) + (##core#inline_allocate + ("C_a_i_flonum_atan2" 4) + (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) + (##core#inline "C_u_i_cplxnum_imag" #(tmp))) + (##core#inline_allocate ("C_a_i_exact_to_inexact" 11) + (##core#inline "C_u_i_cplxnum_real" #(tmp))))))) + +(scheme#numerator (#(procedure #:clean #:enforce #:foldable) scheme#numerator ((or float integer ratnum)) (or float integer)) + ((fixnum) (fixnum) #(1)) + ((bignum) (bignum) #(1)) + ((integer) (integer) #(1)) + ((ratnum) (integer) (##core#inline "C_u_i_ratnum_num" #(1)))) + +(scheme#denominator (#(procedure #:clean #:enforce #:foldable) scheme#denominator ((or float integer ratnum)) (or float integer)) ((integer) (fixnum) (let ((#(tmp) #(1))) '1)) ((ratnum) (integer) (##core#inline "C_u_i_ratnum_denom" #(1)))) @@ -877,6 +881,10 @@ (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)))) @@ -931,10 +939,10 @@ (chicken.base#error (procedure chicken.base#error (* #!rest) noreturn)) (chicken.base#equal=? (#(procedure #:clean #:foldable) chicken.base#equal=? (* *) boolean) - ((fixnum fixnum) (eq? #(1) #(2))) - (((or symbol char eof null undefined) *) (eq? #(1) #(2))) - ((* (or symbol char eof null undefined)) (eq? #(1) #(2))) - ((number number) (= #(1) #(2)))) + ((fixnum fixnum) (scheme#eq? #(1) #(2))) + (((or symbol char eof null undefined) *) (scheme#eq? #(1) #(2))) + ((* (or symbol char eof null undefined)) (scheme#eq? #(1) #(2))) + ((number number) (scheme#= #(1) #(2)))) (chicken.base#gensym (#(procedure #:clean) chicken.base#gensym (#!optional (or string symbol)) symbol)) (chicken.base#char-name (#(procedure #:clean #:enforce) chicken.base#char-name ((or char symbol) #!optional char) *)) ;XXX -> (or char symbol) ? @@ -1326,7 +1334,7 @@ (port? (#(procedure #:pure #:predicate port) port? (*) boolean)) (port-closed? (#(procedure #:clean #:enforce) port-closed? (port) boolean) - ((port) (eq? (##sys#slot #(1) '8) '0))) + ((port) (scheme#eq? (##sys#slot #(1) '8) '0))) (program-name (#(procedure #:clean #:enforce) program-name (#!optional string) string)) @@ -1652,9 +1660,9 @@ ;; A silly procedure, but at least we can "inline" it like this (chicken.irregex#irregex-match? (#(procedure #:clean #:enforce) chicken.irregex#irregex-match? (* string #!optional fixnum fixnum) boolean) - ((* string) (and (irregex-match #(1) #(2)) '#t)) - ((* string fixnum) (and (irregex-match #(1) #(2) #(3)) '#t)) - ((* string fixnum fixnum) (and (irregex-match #(1) #(2) #(3) #(4)) '#t))) + ((* string) (and (chicken.irregex#irregex-match #(1) #(2)) '#t)) + ((* string fixnum) (and (chicken.irregex#irregex-match #(1) #(2) #(3)) '#t)) + ((* string fixnum fixnum) (and (chicken.irregex#irregex-match #(1) #(2) #(3) #(4)) '#t))) ;; These two return #f or a match object (chicken.irregex#irregex-match (#(procedure #:clean #:enforce) chicken.irregex#irregex-match (* string #!optional fixnum fixnum) (or false (struct regexp-match)))) -- 2.11.0