library.scm

Scheme跨平台编译器

(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) (car (car x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr 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#delq x lst)
  (let loop ([lst lst])
    (cond ((null? lst) lst)
	  ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
	  (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )

(define ##sys#not-a-proper-list-error
  (lambda (arg . loc)
    (##sys#signal-hook #:type-error (if (pair? loc) (car loc) #f) "argument is not a proper list" arg) ) )

(define 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-expand
		 [unsafe
		  (if (eq? node '()) 
		      (loop (##sys#slot lsts 1))
		      (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
		 [else
		  (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
			((pair? node)
			 (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
			(else (##sys#not-a-proper-list-error (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) ) )

(define reverse 
  (lambda (lst0)
    (let loop ((lst lst0) (rest '()))
      (cond-expand
       [unsafe
	(if (eq? lst '()) 
	    rest
	    (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))  ) ]
       [else
	(cond ((eq? lst '()) rest)
	      ((pair? lst)
	       (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
	      (else (##sys#not-a-proper-list-error 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 (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-exact size 'make-string)
  #+(not unsafe)
  (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 ##sys#string->list 
  (lambda (s)
    (##sys#check-string s 'string->list)
    (let ((len (##core#inline "C_block_size" s)))
      (let loop ((i 0))
	(if (fx>= i len)
	    '()
	    (cons (##core#inline "C_subchar" s i)
		  (loop (fx+ i 1)) ) ) ) ) ) )

(define string->list ##sys#string->list)

(define (##sys#list->string lst0)
  (cond-expand
    [unsafe
    (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)
        (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
    [else
    (if (not (list? lst0))
      (##sys#not-a-proper-list-error 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 list->string ##sys#list->string)

;;; By Sven Hartrumpf:

(define (##sys#reverse-list->string l)
  (cond-expand
    [unsafe
    (let* ((n (length l))
           (s (##sys#make-string n)))
      (let iter ((l2 l) (n2 (fx- n 1)))
        (cond ((fx>= n2 0)
               (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
               (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
      s ) ]
    [else
    (if (list? l)
      (let* ((n (length l))
             (s (##sys#make-string n)))
        (let iter ((l2 l) (n2 (fx- n 1)))
          (cond ((fx>= n2 0)
                 (let ((c (##sys#slot l2 0)))
                   (##sys#check-char c 'reverse-list->string)
                   (##core#inline "C_setsubchar" s n2 c) )
                 (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
        s )
      (##sys#not-a-proper-list-error l 'reverse-list->string) ) ]
    ) )

(define reverse-list->string ##sys#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) )

(define string-copy
  (lambda (s)
    (##sys#check-string s 'string-copy)
    (let* ([len (##sys#size s)]
	   [s2 (##sys#make-string len)] )
      (##core#inline "C_copy_memory" s2 s len)
      s2) ) )

(define substring
  (lambda (s start . end)
    (##sys#check-string s 'substring)
    (##sys#check-exact start 'substring)
    (let ([end (if (pair? end) 
		   (let ([end (car end)])
		     (##sys#check-exact end 'substring)
		     end) 
		   (##sys#size s) ) ] )
      (cond-expand
       [unsafe (##sys#substring s start end)]
       [else
	(let ([len (##sys#size s)])
	  (if (and (fx<= start end)
		   (fx>= start 0)
		   (fx<= end len) )
	      (##sys#substring s start end)
	      (##sys#signal-hook #:bounds-error 'substring "index out of bounds" start end) ) ) ] ) ) ) )

(define ##sys#substring
  (lambda (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)
  (cond-expand [unsafe (##core#inline "C_u_i_string_equal_p" x y)]
	       [else (##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 
	  (lambda (s1 s2 loc k)
	    (##sys#check-string s1 loc)
	    (##sys#check-string s2 loc)
	    (let ((len1 (##core#inline "C_block_size" s1))
		  (len2 (##core#inline "C_block_size" s2)) )
	      (k len1 len2
		 (##core#inline "C_string_compare"
			    s1
			    s2
			    (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< len1 len2)
			       (eq? cmp 0) ) ) ) ) ) )
  (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 
	  (lambda (s1 s2 loc k)
	    (##sys#check-string s1 loc)
	    (##sys#check-string s2 loc)
	    (let ((len1 (##core#inline "C_block_size" s1))
		  (len2 (##core#inline "C_block_size" s2)) )
	      (k len1 len2
		 (##core#inline "C_string_compare_case_insensitive"
				s1
				s2
				(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< len1 len2)
				  (eq? cmp 0) ) ) ) ) ) )
  (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) ) ) ) ) ) )

(define (##sys#string-append x y)
  (let* ([s1 (##sys#size x)]
	 [s2 (##sys#size y)] 
	 [z (##sys#make-string (fx+ s1 s2))] )
    (##core#inline "C_substring_copy" x z 0 s1 0)
    (##core#inline "C_substring_copy" y z 0 s2 s1)
    z) )

(define 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) ) )

(define string
  (let ([list->string list->string])
    (lambda chars (list->string chars)) ) )

(define (##sys#fragments->string total fs)
  (let ([dest (##sys#make-string total)])
    (let loop ([fs fs] [pos 0])
      (if (null? fs)
	  dest
	  (let* ([f (##sys#slot fs 0)]
		 [flen (##sys#size f)] )
	    (##core#inline "C_substring_copy" f dest 0 flen pos)
	    (loop (##sys#slot fs 1) (fx+ pos flen)) ) ) ) ) )


;;; Numeric routines:

(define (fixnum? x) (##core#inline "C_fixnump" x))
(define (fx+ x y) (##core#inline "C_fixnum_plus" x y))
(define (fx- x y) (##core#inline "C_fixnum_difference" x y))
(define (fx* x y) (##core#inline "C_fixnum_times" x y))
(define (fx= x y) (eq? x y))
(define (fx> x y) (##core#inline "C_fixnum_greaterp" x y))
(define (fx< x y) (##core#inline "C_fixnum_lessp" x y))
(define (fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
(define (fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
(define (fxmin x y) (##core#inline "C_i_fixnum_min" x y))
(define (fxmax x y) (##core#inline "C_i_fixnum_max" x y))
(define (fxneg x) (##core#inline "C_fixnum_negate" x))
(define (fxand x y) (##core#inline "C_fixnum_and" x y))
(define (fxior x y) (##core#inline "C_fixnum_or" x y))
(define (fxxor x y) (##core#inline "C_fixnum_xor" x y))
(define (fxnot x) (##core#inline "C_fixnum_not" x))
(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))

(define fx/
  (lambda (x y)
    (cond-expand
     [unsafe (##core#inline "C_fixnum_divide" x y)]
     [else
      (if (eq? y 0)
	  (##sys#signal-hook #:arithmetic-error 'fx/ "division by zero" x y)
	  (##core#inline "C_fixnum_divide" x y) ) ] ) ) )

(define fxmod
  (lambda (x y)
    (cond-expand
     [unsafe (##core#inline "C_fixnum_modulo" x y)]
     [else
      (if (eq? y 0)
	  (##sys#signal-hook #:arithmetic-error 'fxmod "division by zero" x y)
	  (##core#inline "C_fixnum_modulo" x y) ) ] ) ) )