c-platform.scm

Scheme跨平台编译器

(rewrite 'cadadr 2 1 "C_u_i_cadadr" #f #f)
(rewrite 'caddar 2 1 "C_u_i_caddar" #f #f)
(rewrite 'cadddr 2 1 "C_u_i_cadddr" #f #f)
(rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f #f)
(rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f #f)
(rewrite 'cdadar 2 1 "C_u_i_cdadar" #f #f)
(rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f #f)
(rewrite 'cddaar 2 1 "C_u_i_cddaar" #f #f)
(rewrite 'cddadr 2 1 "C_u_i_cddadr" #f #f)
(rewrite 'cdddar 2 1 "C_u_i_cdddar" #f #f)
(rewrite 'cddddr 2 1 "C_u_i_cddddr" #f #f)

(rewrite 'cddr 2 1 "C_i_cddr" #t #f)
(rewrite 'cdddr 2 1 "C_i_cdddr" #t #f)
(rewrite 'cddddr 2 1 "C_i_cddddr" #t #f)

(rewrite 'cdr 7 1 "C_slot" 1 #f)
(rewrite 'cdr 2 1 "C_i_cdr" #t #f)

(rewrite 'eq? 1 2 "C_eqp")
(rewrite 'eqv? 1 2 "C_i_eqvp")

(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot")
(rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref")
(rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp")
(rewrite 'length 2 1 "C_i_length" #t "C_block_size")
(rewrite 'not 2 1 "C_i_not" #t #f)
(rewrite 'char? 2 1 "C_charp" #t #f)
(rewrite 'string? 2 1 "C_i_stringp" #t #f)
(rewrite 'locative? 2 1 "C_i_locativep" #t #f)
(rewrite 'symbol? 2 1 "C_i_symbolp" #t #f)
(rewrite 'vector? 2 1 "C_i_vectorp" #t #f)
(rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
(rewrite 'procedure? 2 1 "C_i_closurep" #t #f)
(rewrite 'port? 2 1 "C_i_portp" #t #f)
(rewrite 'boolean? 2 1 "C_booleanp" #t #f)
(rewrite 'number? 2 1 "C_i_numberp" #t #f)
(rewrite 'complex? 2 1 "C_i_numberp" #t #f)
(rewrite 'rational? 2 1 "C_i_numberp" #t #f)
(rewrite 'real? 2 1 "C_i_numberp" #t #f)
(rewrite 'integer? 2 1 "C_i_integerp" #t #f)
(rewrite 'flonum? 2 1 "C_i_flonump" #t #f)
(rewrite 'fixnum? 2 1 "C_fixnump" #t #f)
(rewrite 'finite? 2 1 "C_i_finitep" #f #f)
(rewrite '##sys#pointer? 2 1 "C_pointerp" #t #f)
(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f)
(rewrite 'exact? 2 1 "C_fixnump" #f #f)
(rewrite 'exact? 2 1 "C_i_exactp" #t #f)
(rewrite 'exact? 2 1 "C_u_i_exactp" #f #f)
(rewrite 'inexact? 2 1 "C_nfixnump" #f #f)
(rewrite 'inexact? 2 1 "C_i_inexactp" #t #f)
(rewrite 'inexact? 2 1 "C_u_i_inexactp" #f #f)
(rewrite 'list? 2 1 "C_i_listp" #t #f)
(rewrite 'proper-list? 2 1 "C_i_listp" #t #f)
(rewrite 'eof-object? 2 1 "C_eofp" #t #f)
(rewrite 'string-ref 2 2 "C_subchar" #f #f)
(rewrite 'string-ref 2 2 "C_i_string_ref" #t #f)
(rewrite 'string-set! 2 3 "C_setsubchar" #f #f)
(rewrite 'string-set! 2 3 "C_i_string_set" #t #f)
(rewrite 'vector-ref 2 2 "C_slot" #f #f)
(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t #f)
(rewrite 'char=? 2 2 "C_eqp" #t #f)
(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t #f)
(rewrite 'char<? 2 2 "C_fixnum_lessp" #t #f)
(rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t #f)
(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f)
(rewrite '##sys#slot 2 2 "C_slot" #t #f)		; consider as safe, the primitive is unsafe anyway.
(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ; must be safe for pattern matcher
(rewrite '##sys#size 2 1 "C_block_size" #t #f)
(rewrite 'fxnot 2 1 "C_fixnum_not" #t #f)
(rewrite 'fx* 2 2 "C_fixnum_times" #t #f)
(rewrite 'fx/ 2 2 "C_fixnum_divide" #f #f)
(rewrite 'fxmod 2 2 "C_fixnum_modulo" #f #f)
(rewrite 'fx= 2 2 "C_eqp" #t #f)
(rewrite 'fx> 2 2 "C_fixnum_greaterp" #t #f)
(rewrite 'fx< 2 2 "C_fixnum_lessp" #t #f)
(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t #f)
(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t #f)
(rewrite 'fp= 2 2 "C_flonum_equalp" #t #f)
(rewrite 'fp> 2 2 "C_flonum_greaterp" #t #f)
(rewrite 'fp< 2 2 "C_flonum_lessp" #t #f)
(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t #f)
(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t #f)
(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t #f)
(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t #f)
(rewrite 'fpmax 2 2 "C_i_flonum_max" #t #f)
(rewrite 'fpmin 2 2 "C_i_flonum_min" #t #f)
(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t #f)
(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t #f)
(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t #f)
(rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t #f)
(rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t #f)
(rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t #f)
(rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t #f)
(rewrite 'list-tail 2 2 "C_i_list_tail" #t #f)
(rewrite '##sys#structure? 2 2 "C_i_structurep" #t #f)
(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t #f)
(rewrite 'block-ref 2 2 "C_slot" #f #f)	; ok to be unsafe, lolevel is anyway
(rewrite 'number-of-slots 2 1 "C_block_size" #f #f)

(rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")
(rewrite 'assv 2 2 "C_i_assv" #t #f)
(rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")
(rewrite 'memv 2 2 "C_i_memv" #t #f)
(rewrite 'assq 17 2 "C_i_assq" "C_u_i_assq")
(rewrite 'memq 17 2 "C_i_memq" "C_u_i_memq")
(rewrite 'assoc 2 2 "C_i_assoc" #t #f)
(rewrite 'member 2 2 "C_i_member" #t #f)

(rewrite '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 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")
(rewrite 'abs 16 1 "C_a_i_abs" #t words-per-flonum)

(rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_a_i_bitwise_xor" words-per-flonum)
(rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_a_i_bitwise_and" words-per-flonum)
(rewrite 'bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_a_i_bitwise_ior" words-per-flonum)

(rewrite 'bitwise-not 22 1 "C_a_i_bitwise_not" #t words-per-flonum "C_fixnum_not")

(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #t words-per-flonum)
(rewrite 'fp- 16 2 "C_a_i_flonum_difference" #t words-per-flonum)
(rewrite 'fp* 16 2 "C_a_i_flonum_times" #t words-per-flonum)
(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #t words-per-flonum)
(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #t words-per-flonum)

(rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum)
(rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum)
(rewrite 'cos 16 1 "C_a_i_cos" #t words-per-flonum)
(rewrite 'tan 16 1 "C_a_i_tan" #t words-per-flonum)
(rewrite 'log 16 1 "C_a_i_log" #t words-per-flonum)
(rewrite 'asin 16 1 "C_a_i_asin" #t words-per-flonum)
(rewrite 'acos 16 1 "C_a_i_acos" #t words-per-flonum)
(rewrite 'atan 16 1 "C_a_i_atan" #t words-per-flonum)
(rewrite 'sqrt 16 1 "C_a_i_sqrt" #t words-per-flonum)
(rewrite 'atan 16 2 "C_a_i_atan2" #t words-per-flonum)

(rewrite 'zero? 5 "C_eqp" 0 'fixnum)
(rewrite 'zero? 2 1 "C_i_zerop" #t #f)
(rewrite 'zero? 2 1 "C_u_i_zerop" #f #f)
(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum)
(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum)
(rewrite 'positive? 2 1 "C_i_positivep" #t #f)
(rewrite 'positive? 2 1 "C_u_i_positivep" #f #f)
(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum)
(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum)
(rewrite 'negative? 2 1 "C_i_negativep" #t #f)
(rewrite 'negative? 2 1 "C_u_i_negativep" #f #f)

(rewrite 'vector-length 6 "C_fix" "C_header_size" #f)
(rewrite 'string-length 6 "C_fix" "C_header_size" #f)
(rewrite 'char->integer 6 "C_fix" "C_character_code" #t)
(rewrite 'integer->char 6 "C_make_character" "C_unfix" #t)

(rewrite 'vector-length 2 1 "C_i_vector_length" #t #f)
(rewrite 'string-length 2 1 "C_i_string_length" #t #f)
(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f)

(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t #f)
(rewrite '##sys#check-number 2 1 "C_i_check_number" #t #f)
(rewrite '##sys#check-list 2 1 "C_i_check_list" #t #f)
(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t #f)
(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t #f)
(rewrite '##sys#check-string 2 1 "C_i_check_string" #t #f)
(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t #f)
(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t #f)
(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t #f)
(rewrite '##sys#check-char 2 1 "C_i_check_char" #t #f)
(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t #f)
(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t #f)
(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t #f)
(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t #f)
(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t #f)
(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t #f)
(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t #f)
(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t #f)
(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t #f)
(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t #f)

(rewrite '= 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 'setter 11 1 '##sys#setter #t)
(rewrite 'for-each 11 2 '##sys#for-each #t)
(rewrite 'map 11 2 '##sys#map #t)
(rewrite 'block-set! 11 3 '##sys#setslot #t)
(rewrite '##sys#block-set! 11 3 '##sys#setslot #f)
(rewrite '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 'vector-set! 11 3 '##sys#setslot #f)
(rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f)

(rewrite 'gcd 12 '##sys#gcd #t 2)
(rewrite 'lcm 12 '##sys#lcm #t 2)
(rewrite 'identity 12 #f #t 1)

(rewrite 'gcd 18 0)
(rewrite 'lcm 18 1)
(rewrite 'list 18 '())

(rewrite 'argv 13 "C_get_argv" #t)

(rewrite '* 16 2 "C_a_i_times" #t 4)	; words-per-flonum
(rewrite '+ 16 2 "C_a_i_plus" #t 4)	; words-per-flonum
(rewrite '- 16 2 "C_a_i_minus" #t 4)	; words-per-flonum
(rewrite '/ 16 2 "C_a_i_divide" #t 4)	; words-per-flonum
(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 "C_times" #t)
(rewrite '- 13 "C_minus" #t)
(rewrite '+ 13 "C_plus" #t)
(rewrite '/ 13 "C_divide" #t)
(rewrite '= 13 "C_nequalp" #t)
(rewrite '> 13 "C_greaterp" #t)
(rewrite '< 13 "C_lessp" #t)
(rewrite '>= 13 "C_greater_or_equal_p" #t)
(rewrite '<= 13 "C_less_or_equal_p" #t)

(rewrite 'exact->inexact 13 "C_exact_to_inexact" #t)
(rewrite 'string->number 13 "C_string_to_number" #t)
(rewrite 'number->string 13 "C_number_to_string" #t)
(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t)
(rewrite '##sys#floor 13 "C_flonum_floor" #t)
(rewrite '##sys#ceiling 13 "C_flonum_ceiling" #t)
(rewrite '##sys#truncate 13 "C_flonum_truncate" #t)
(rewrite '##sys#round 13 "C_flonum_round" #t)
(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t)
(rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t)
(rewrite 'return-to-host 13 "C_return_to_host" #t)
(rewrite '##sys#context-switch 13 "C_context_switch" #t)
(rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t)
(rewrite '##sys#make-symbol 13 "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 'add1 14 'fixnum 1 "C_fixnum_increase" "C_u_fixnum_increase")
(rewrite 'sub1 14 'fixnum 1 "C_fixnum_decrease" "C_u_fixnum_decrease")
(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")

(rewrite 'even? 2 1 "C_i_evenp" #t #f)
(rewrite 'even? 2 1 "C_u_i_evenp" #f #f)
(rewrite 'odd? 2 1 "C_i_oddp" #t #f)
(rewrite 'odd? 2 1 "C_u_i_oddp" #f #f)

(rewrite 'floor 15 'flonum 'fixnum '##sys#floor #f)
(rewrite 'ceiling 15 'flonum 'fixnum '##sys#ceiling #f)
(rewrite 'truncate 15 'flonum 'fixnum '##sys#truncate #f)
(rewrite 'round 15 'flonum 'fixnum '##sys#round #f)

(rewrite '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 '(3))
(rewrite '##sys#list 16 #f "C_a_i_list" #t '(3))
(rewrite 'vector 16 #f "C_a_i_vector" #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)
(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care

(rewrite
 '##sys#setslot 8