library.scm

Scheme跨平台编译器

(define (flonum? x) (##core#inline "C_i_flonump" x))

(define (finite? x) 
  (##sys#check-number x 'finite?)
  (##core#inline "C_i_finitep" x) )

(define (fp+ x y) 
  (cond-expand
   (unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
   (else 
    (if (and (flonum? x)
             (flonum? y))
        (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)
        (##sys#signal-hook #:type-error 'fp+ "not flonums" x y)))))

(define (fp- x y) 
  (cond-expand
   (unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
   (else 
    (if (and (flonum? x)
             (flonum? y))
        (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)
        (##sys#signal-hook #:type-error 'fp- "not flonums" x y)))))

(define (fp* x y) 
  (cond-expand
   (unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
   (else 
    (if (and (flonum? x)
             (flonum? y))
        (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)
        (##sys#signal-hook #:type-error 'fp* "not flonums" x y)))))

(define (fp= x y) 
  (cond-expand
   (unsafe (##core#inline "C_flonum_equalp" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_flonum_equalp" x y)
             (##sys#signal-hook #:type-error 'fp= "not flonums" x y)))))

(define (fp> x y) 
  (cond-expand
   (unsafe (##core#inline "C_flonum_greaterp" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_flonum_greaterp" x y)
             (##sys#signal-hook #:type-error 'fp> "not flonums" x y)))))

(define (fp< x y) 
  (cond-expand 
   (unsafe (##core#inline "C_flonum_lessp" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_flonum_lessp" x y)
             (##sys#signal-hook #:type-error 'fp< "not flonums" x y)))))

(define (fp>= x y) 
  (cond-expand
   (unsafe (##core#inline "C_flonum_greater_or_equal_p" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_flonum_greater_or_equal_p" x y)
             (##sys#signal-hook #:type-error 'fp>= "not flonums" x y)))))

(define (fp<= x y) 
  (cond-expand
   (unsafe (##core#inline "C_flonum_less_or_equal_p" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_flonum_less_or_equal_p" x y)
             (##sys#signal-hook #:type-error 'fp<= "not flonums" x y)))))

(define (fpneg x) 
  (cond-expand
   (unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
   (else (if (flonum? x)
             (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)
             (##sys#signal-hook #:type-error 'fpneg "not flonums" x)))))

(define (fpmax x y) 
  (cond-expand
   (unsafe (##core#inline "C_i_flonum_max" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_i_flonum_max" x y)
             (##sys#signal-hook #:type-error 'fpmax "not flonums" x y)))))

(define (fpmin x y) 
  (cond-expand
   (unsafe (##core#inline "C_i_flonum_min" x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline "C_i_flonum_min" x y)
             (##sys#signal-hook #:type-error 'fpmin "not flonums" x y)))))

(define (fp/ x y)
  (cond-expand
   (unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
   (else (if (and (flonum? x)
                  (flonum? y))
             (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)
             (##sys#signal-hook #:type-error 'fp/ "not flonums" x y)))))

(define * (##core#primitive "C_times"))
(define - (##core#primitive "C_minus"))
(define + (##core#primitive "C_plus"))
(define / (##core#primitive "C_divide"))
(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 add1 (lambda (n) (+ n 1)))
(define sub1 (lambda (n) (- n 1)))

(define ##sys#floor (##core#primitive "C_flonum_floor"))
(define ##sys#ceiling (##core#primitive "C_flonum_ceiling"))
(define ##sys#truncate (##core#primitive "C_flonum_truncate"))
(define ##sys#round (##core#primitive "C_flonum_round"))
(define quotient (##core#primitive "C_quotient"))
(define ##sys#cons-flonum (##core#primitive "C_cons_flonum"))
(define (##sys#number? x) (##core#inline "C_i_numberp" x))
(define number? ##sys#number?)
(define complex? number?)
(define real? number?)
(define rational? number?)
(define ##sys#flonum-fraction (##core#primitive "C_flonum_fraction"))
(define (##sys#integer? x) (##core#inline "C_i_integerp" x))
(define integer? ##sys#integer?)
(define (##sys#exact? x) (##core#inline "C_i_exactp" x))
(define (##sys#inexact? x) (##core#inline "C_i_inexactp" x))
(define exact? ##sys#exact?)
(define inexact? ##sys#inexact?)
(define expt (##core#primitive "C_expt"))
(define (##sys#fits-in-int? n) (##core#inline "C_fits_in_int_p" n))
(define (##sys#fits-in-unsigned-int? n) (##core#inline "C_fits_in_unsigned_int_p" n))
(define (##sys#flonum-in-fixnum-range? n) (##core#inline "C_flonum_in_fixnum_range_p" n))
(define (##sys#double->number n) (##core#inline "C_double_to_number" n))
(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 (abs n) (##core#inline_allocate ("C_a_i_abs" 4) n))	; 4 => words-per-flonum

(define (angle n)
  (##sys#check-number n 'angle)
  (if (< n 0) (fp* 2.0 (acos 0.0)) 0.0) )

(define (real-part n)
  (##sys#check-number n 'real-part)
  n)

(define (imag-part n)
  (##sys#check-number n 'imag-part)
  0)

(define (numerator n)
  (##sys#check-number n 'numerator)
  (if (##core#inline "C_i_integerp" n)
      n
      (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )

(define (denominator n)
  (##sys#check-number n 'denominator)
  (if (##core#inline "C_i_integerp" n)
      1
      (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )

(define magnitude abs)

(define (signum n)
  (cond ((> n 0) (if (##sys#exact? n) 1 1.0))
	((< n 0) (if (##sys#exact? n) -1 -1.0))
	(else (if (##sys#exact? n) 0 0.0) ) ) )

(define ##sys#exact->inexact (##core#primitive "C_exact_to_inexact"))
(define exact->inexact ##sys#exact->inexact)
(define (##sys#inexact->exact n) (##core#inline "C_i_inexact_to_exact" n))
(define inexact->exact ##sys#inexact->exact)

(define (floor x)
  (##sys#check-number x 'floor)
  (if (##core#inline "C_fixnump" x) 
      x
      (##sys#floor x) ) )

(define (ceiling x)
  (##sys#check-number x 'ceiling)
  (if (##core#inline "C_fixnump" x) 
      x
      (##sys#ceiling x) ) )

(define (truncate x)
  (##sys#check-number x 'truncate)
  (if (##core#inline "C_fixnump" x) 
      x
      (##sys#truncate x) ) )

(define (round x)
  (##sys#check-number x 'round)
  (if (##core#inline "C_fixnump" x) 
      x
      (##sys#round x) ) )

(define remainder 
  (lambda (x y) (- x (* (quotient x y) y))) )

(define modulo
  (let ([floor floor])
    (lambda (x y)
      (let ((div (/ x y)))
	(- x (* (if (integer? div)
		    div
		    (let* ([fd (floor div)]
			   [fdx (##core#inline "C_quickflonumtruncate" fd)] )
		      (if (= fd fdx)
			  fdx
			  fd) ) )
		y) ) ) ) ) )

(define (even? n) (##core#inline "C_i_evenp" n))
(define (odd? n) (##core#inline "C_i_oddp" n))

(define max)
(define min)

(let ([> >]
      [< <] )
  (letrec ([maxmin
	    (lambda (n1 ns pred)
	      (let loop ((nbest n1) (ns ns))
		(if (eq? ns '())
		    nbest
		    (let ([ni (##sys#slot ns 0)])
		      (loop (if (pred ni nbest)
				(if (and (##core#inline "C_blockp" nbest) 
					 (##core#inline "C_flonump" nbest) 
					 (not (##core#inline "C_blockp" ni)) )
				    (exact->inexact ni)
				    ni)
				nbest)
			    (##sys#slot ns 1) ) ) ) ) ) ] )

    (set! max (lambda (n1 . ns) (maxmin n1 ns >)))
    (set! min (lambda (n1 . ns) (maxmin n1 ns <))) ) )

(define (exp n)
  (##core#inline_allocate ("C_a_i_exp" 4) n) )

(define (log n)
  (##core#inline_allocate ("C_a_i_log" 4) n) )

(define (sin n)
  (##core#inline_allocate ("C_a_i_sin" 4) n) )

(define (cos n)
  (##core#inline_allocate ("C_a_i_cos" 4) n) )

(define (tan n)
  (##core#inline_allocate ("C_a_i_tan" 4) n) )

(define (asin n)
  (##core#inline_allocate ("C_a_i_asin" 4) n) )

(define (acos n)
  (##core#inline_allocate ("C_a_i_acos" 4) n) )

(define (sqrt n)
  (##core#inline_allocate ("C_a_i_sqrt" 4) n) )

(define (atan n1 . n2)
  (if (null? n2) 
      (##core#inline_allocate ("C_a_i_atan" 4) n1)
      (let ([n2 (car n2)])
	(##core#inline_allocate ("C_a_i_atan2" 4) n1 n2) ) ) )

(define ##sys#gcd
  (let ((remainder remainder))
    (lambda (x y)
      (let loop ((x x) (y y))
	(if (zero? y)
	    (abs x)
	    (loop y (remainder x y)) ) ) ) ) )

(define (gcd . ns)
  (if (eq? ns '())
      0
      (let loop ([ns ns] [f #t])
	(let ([head (##sys#slot ns 0)]
	      [next (##sys#slot ns 1)] )
	  (cond-expand [unsafe] [else (when f (##sys#check-integer head 'gcd))])
	  (if (null? next)
	      (abs head)
	      (let ([n2 (##sys#slot next 0)])
		(cond-expand [unsafe] [else (##sys#check-integer n2 'gcd)])
		(loop (cons (##sys#gcd head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )

(define (##sys#lcm x y)
  (quotient (* x y) (##sys#gcd x y)) )

(define (lcm . ns)
  (if (null? ns)
      1
      (let loop ([ns ns] [f #t])
	(let ([head (##sys#slot ns 0)]
	      [next (##sys#slot ns 1)] )
	  (cond-expand [unsafe] [else (when f (##sys#check-integer head 'lcm))])
	  (if (null? next)
	      (abs head)
	      (let ([n2 (##sys#slot next 0)])
		(cond-expand [unsafe] [else (##sys#check-integer n2 'lcm)])
		(loop (cons (##sys#lcm head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )

(define ##sys#string->number (##core#primitive "C_string_to_number"))
(define string->number ##sys#string->number)
(define ##sys#number->string (##core#primitive "C_number_to_string"))
(define number->string ##sys#number->string)

(define (flonum-print-precision #!optional prec)
  (let ([prev (##core#inline "C_get_print_precision")])
    (when prec
      (##sys#check-exact prec 'flonum-print-precision)
      (##core#inline "C_set_print_precision" prec) )
    prev ) )


;;; Symbols:

(define ##sys#make-symbol (##core#primitive "C_make_symbol"))
(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))

(define (##sys#string->symbol str)
  (##sys#check-string str)
  (##sys#intern-symbol str) )

(define ##sys#symbol->string)
(define ##sys#symbol->qualified-string)
(define ##sys#qualified-symbol-prefix)

(let ([string-append string-append]
      [string-copy string-copy] )

  (define (split str len)
    (let ([b0 (##sys#byte str 0)])	; we fetch the byte, wether len is 0 or not
      (if (and (fx> len 0) (fx< b0 len) (fx<= b0 namespace-max-id-len))
	  (fx+ b0 1)
	  #f) ) )

  (set! ##sys#symbol->string
    (lambda (s)
      (let* ([str (##sys#slot s 1)]
	     [len (##sys#size str)]
	     [i (split str len)] )
	(if i (##sys#substring str i len) str) ) ) )

  (set! ##sys#symbol->qualified-string 
    (lambda (s)
      (let* ([str (##sys#slot s 1)]
	     [len (##sys#size str)] 
	     [i (split str len)] )
	(if i
	    (string-append "##" (##sys#substring str 1 i) "#" (##sys#substring str i len))
	    str) ) ) )

  (set! ##sys#qualified-symbol-prefix 
    (lambda (s)
      (let* ([str (##sys#slot s 1)]
	     [len (##sys#size str)]
	     [i (split str len)] )
	(and i (##sys#substring str 0 i)) ) ) ) )

(define ##sys#string->qualified-symbol
  (lambda (prefix str)
    (##sys#string->symbol
     (if prefix
	 (##sys#string-append prefix str)
	 str) ) ) )

(define (symbol->string s)
  (##sys#check-symbol s 'symbol->string)
  (string-copy (##sys#symbol->string s) ) )

(define string->symbol
  (let ([string-copy string-copy])
    (lambda (str)
      (##sys#check-string str 'string->symbol)
      (##sys#intern-symbol (string-copy str)) ) ) )

(define string->uninterned-symbol