c-platform.scm

Scheme跨平台编译器

 (lambda (db classargs cont callargs)
   ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>)
   ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)
   (and (= (length callargs) 3)
	(make-node 
	 '##core#call '(#t)
	 (list cont
	       (make-node
		'##core#inline
		(let ([val (third callargs)])
		  (if (and (eq? 'quote (node-class val))
			   (immediate? (first (node-parameters val))) ) 
		      '("C_i_set_i_slot")
		      '("C_i_setslot") ) )
		callargs) ) ) ) ) )

(rewrite 'fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus")
(rewrite 'fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference")
(rewrite 'fxshl 17 2 "C_fixnum_shift_left")
(rewrite 'fxshr 17 2 "C_fixnum_shift_right")
(rewrite 'fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate")
(rewrite 'fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor")
(rewrite 'fxand 17 2 "C_fixnum_and" "C_u_fixnum_and")
(rewrite 'fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")

(rewrite
 'arithmetic-shift 8
 (lambda (db classargs cont callargs)
   ;; (arithmetic-shift <x> <-int>) -> (##core#inline "C_fixnum_shift_right" <x> -<int>)
   ;; (arithmetic-shift <x> <+int>) -> (##core#inline "C_fixnum_shift_left" <x> <int>)
   ;; _ -> (##core#inline "C_a_i_arithmetic_shift" <x> <y>)
   ;; not in fixnum-mode: _ -> (##core#inline_allocate ("C_a_i_arithmetic_shift" words-per-flonum) <x> <y>)
   (and (= 2 (length callargs))
	(let ([val (second callargs)])
	  (make-node
	   '##core#call '(#t)
	   (list cont
		 (or (and-let* ([(eq? 'quote (node-class val))]
				[(eq? number-type 'fixnum)]
				[n (first (node-parameters val))]
				[(and (fixnum? n) (not (big-fixnum? n)))] )
		       (if (negative? n)
			   (make-node 
			    '##core#inline '("C_fixnum_shift_right")
			    (list (first callargs) (qnode (- n))) )
			   (make-node
			    '##core#inline '("C_fixnum_shift_left")
			    (list (first callargs) val) ) ) )
		     (if (eq? number-type 'fixnum)
			 (make-node '##core#inline '("C_i_fixnum_arithmetic_shift") callargs)
			 (make-node '##core#inline_allocate (list "C_a_i_arithmetic_shift" words-per-flonum) 
				    callargs) ) ) ) ) ) ) ) )

(rewrite '##sys#byte 17 2 "C_subbyte")
(rewrite '##sys#setbyte 17 3 "C_setbyte")
(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")
(rewrite '##sys#peek-byte 17 2 "C_peek_byte")
(rewrite 'pointer->object 17 2 "C_pointer_to_object")
(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 '##sys#double->number 17 1 "C_double_to_number")
(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 '##sys#fudge 17 1 "C_fudge")
(rewrite '##sys#fits-in-int? 17 1 "C_fits_in_int_p")
(rewrite '##sys#fits-in-unsigned-int? 17 1 "C_fits_in_unsigned_int_p")
(rewrite '##sys#flonum-in-fixnum-range? 17 1 "C_flonum_in_fixnum_range_p")
(rewrite '##sys#permanent? 17 1 "C_permanentp")
(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp")
(rewrite 'null-pointer? 17 1 "C_i_null_pointerp" "C_null_pointerp")
(rewrite '##sys#immediate? 17 1 "C_immp")
(rewrite 'locative->object 17 1 "C_i_locative_to_object")
(rewrite 'locative-set! 17 2 "C_i_locative_set")
(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp")
(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")
(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")
(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")
(rewrite '##sys#foreign-number-vector-argument 17 2 "C_i_foreign_number_vector_argumentp")
(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")
(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")
(rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp")
(rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp")
(rewrite '##sys#direct-return 17 2 "C_direct_return")

(rewrite 'byte-vector-ref 2 2 "C_subbyte" #f #f) ; DEPRECATED
(rewrite 'byte-vector-set! 2 3 "C_setbyte" #f #f) ; DEPRECATED
(rewrite 'byte-vector-length 2 1 "C_block_size" #f #f) ; DEPRECATED
(rewrite 'blob-size 2 1 "C_block_size" #f #f) ; DEPRECATED

(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f)
(rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f #f)
(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f)
(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f)

(rewrite 'u32vector-ref 22 2 "C_a_i_u32vector_ref" #f words-per-flonum "C_u_i_u32vector_ref")
(rewrite 's32vector-ref 22 2 "C_a_i_s32vector_ref" #f words-per-flonum "C_u_i_s32vector_ref")

(rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f #f)
(rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f #f)
(rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f #f)
(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f)
(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f)
(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f)

(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f)
(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f)
(rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f #f)
(rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f #f)
(rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f #f)
(rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f #f)
(rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f #f)
(rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f #f)

(rewrite 'not-pair? 17 1 "C_i_not_pair_p")
(rewrite 'atom? 17 1 "C_i_not_pair_p")
(rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp")

(rewrite 'u8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 's8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 'u16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 's16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 'u32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 's32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 'f32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
(rewrite 'f64vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED

(rewrite 'u8vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 's8vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 'u16vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 's16vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 'u32vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 's32vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 'f32vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 'f64vector->blob/shared 7 1 "C_slot" 1 #f)

(let ()
  (define (rewrite-make-vector db classargs cont callargs)
    ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>))
    ;; - <n> should be less or equal to 32.
    (let ([argc (length callargs)])
      (and (pair? callargs)
	   (let ([n (first callargs)])
	     (and (eq? 'quote (node-class n))
		  (let ([tmp (gensym)]
			[c (first (node-parameters n))] )
		    (and (fixnum? c)
			 (<= c 32)
			 (let ([val (if (pair? (cdr callargs))
					(second callargs)
					(make-node '##core#undefined '() '()) ) ] )
			   (make-node
			    'let
			    (list tmp)
			    (list val
				  (make-node
				   '##core#call '(#t)
				   (list cont
					 (make-node
					  '##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 '##sys#make-vector 8 rewrite-make-vector) )

(rewrite 'thread-specific 7 1 "C_slot" 10 #f)
(rewrite 'thread-specific-set! 20 2 "C_i_setslot" 10 #f)

(let ()
  (define (rewrite-call/cc db classargs cont callargs)
    ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)
    (and (= 1 (length callargs))
	 (let ([val (first callargs)])
	   (and (eq? '##core#variable (node-class val))
		(and-let* ([proc (get db (first (node-parameters val)) 'value)]
			   [(eq? '##core#lambda (node-class proc))] )
		  (let ([llist (third (node-parameters proc))])
		    (decompose-lambda-list 
		     llist
		     (lambda (vars argc rest)
		       (and (= argc 2)
			    (let ([var (or rest (second llist))])
			      (and (not (get db var 'references))
				   (not (get db var 'assigned)) 
				   (make-node
				    '##core#call '(#t)
				    (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
  (rewrite 'call-with-current-continuation 8 rewrite-call/cc)
  (rewrite 'call/cc 8 rewrite-call/cc) )

(declare (hide setter-map))

(define setter-map
  '((car . set-car!)
    (cdr . set-cdr!)
    (hash-table-ref . hash-table-set!)
    (block-ref . block-set!)
    (byte-vector-ref . byte-vector-set!) ; DEPRECATED
    (locative-ref . locative-set!)
    (u8vector-ref . u8vector-set!)
    (s8vector-ref . s8vector-set!)
    (u16vector-ref . u16vector-set!)
    (s16vector-ref . s16vector-set!)
    (u32vector-ref . u32vector-set!)
    (s32vector-ref . s32vector-set!)
    (f32vector-ref . f32vector-set!)
    (f64vector-ref . f64vector-set!)
    (pointer-u8-ref . pointer-u8-set!)
    (pointer-s8-ref . pointer-s8-set!)
    (pointer-u16-ref . pointer-u16-set!)
    (pointer-s16-ref . pointer-s16-set!)
    (pointer-u32-ref . pointer-u32-set!)
    (pointer-s32-ref . pointer-s32-set!)
    (pointer-f32-ref . pointer-f32-set!)
    (pointer-f64-ref . pointer-f64-set!)
    (string-ref . string-set!)
    (global-ref . global-set!)
    (vector-ref . vector-set!) ) )

(rewrite
 '##sys#setter 8
 (lambda (db classargs cont callargs)
   ;; (setter <known-getter>) -> <known-setter>
   (and (= 1 (length callargs))
	(let ((arg (car callargs)))
	  (and (eq? '##core#variable (node-class arg))
	       (let ((sym (car (node-parameters arg))))
		 (and (or (get db sym 'standard-binding)
			  (get db sym 'extended-binding))
		      (and-let* ((a (assq sym setter-map)))
			(make-node
			 '##core#call '(#t)
			 (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) )
			       
(rewrite 'void 3 '##sys#undefined-value)
(rewrite '##sys#void 3 '##sys#undefined-value)

(rewrite
 'any? 8
 (lambda (db classargs cont callargs) 
   (and (= 1 (length callargs))
	(let ((arg (car callargs)))
	  (make-node
	   '##core#call '(#t) 
	   (list cont
		 (if (and (eq? '##core#variable (node-class arg))
			  (not (get db (car (node-parameters arg)) 'global)) )
		     (qnode #t)
		     (make-node 
		      '##core#inline '("C_anyp")
		      (list arg)) ) ) ) ) ) ) )

(rewrite
 'bit-set? 8
 (lambda (db classargs cont callargs)
   (and (= 2 (length callargs))
	(make-node
	 '##core#call '(#t)
	 (list cont
	       (make-node
		'##core#inline 
		(list (if (eq? number-type 'fixnum) "C_u_i_bit_setp" "C_i_bit_setp"))
		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 'read-string 23 1 '##sys#read-string/port '##sys#standard-input)
(rewrite 'substring=? 23 2 '##sys#substring=? 0 0 #f)
(rewrite 'substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)
(rewrite 'substring-index 23 2 '##sys#substring-index 0)
(rewrite 'substring-index-ci 23 2 '##sys#substring-index-ci 0)