library.scm

Scheme跨平台编译器

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

(define gensym
  (let ([counter -1])
    (lambda str-or-sym
      (let ([err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))])
	(set! counter (fx+ counter 1))
	(##sys#make-symbol
	 (##sys#string-append
	  (if (eq? str-or-sym '())
	      "g"
	      (let ([prefix (car str-or-sym)])
		(or (and (##core#inline "C_blockp" prefix)
			 (cond [(##core#inline "C_stringp" prefix) prefix]
			       [(##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix)]
			       [else (err prefix)] ) )
		    (err prefix) ) ) )
	  (##sys#number->string counter) ) ) ) ) ) )


;;; Keywords:

(define (keyword? x)
  (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0))) )

(define string->keyword
  (let ([string string] )
    (lambda (s)
      (##sys#check-string s 'string->keyword)
      (##sys#intern-symbol (##sys#string-append (string (integer->char 0)) s)) ) ) )

(define keyword->string
  (let ([keyword? keyword?])
    (lambda (kw)
      (if (keyword? kw)
	  (##sys#symbol->string kw)
	  (##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )

(define ##sys#get-keyword 
  (lambda (key args0 . default)
    (##sys#check-list args0 'get-keyword)
    (let ([a (memq key args0)])
      (if a
	  (let ([r (##sys#slot a 1)])
	    (if (pair? r)
		(##sys#slot r 0)
		(##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
	  (and (pair? default) ((car default))) ) ) ) )

(define get-keyword ##sys#get-keyword)


;;; Blob:

(define (##sys#make-blob size)
  (let ([bv (##sys#allocate-vector size #t #f #t)])
    (##core#inline "C_string_to_bytevector" bv)
    bv) )

(define (make-blob size)
  (##sys#check-exact size 'make-blob)
  (##sys#make-blob size) )

(define (blob? x)
  (and (##core#inline "C_blockp" x)
       (##core#inline "C_bytevectorp" x) ) )

(define (blob-size bv)
  (##sys#check-blob bv 'blob-size)
  (##sys#size bv) )

(define (string->blob s)
  (##sys#check-string s 'string->blob)
  (let* ([n (##sys#size s)]
         [bv (##sys#make-blob n)] )
    (##core#inline "C_copy_memory" bv s n) 
    bv) )

(define (blob->string bv)
  (##sys#check-blob bv 'blob->string)
  (let* ([n (##sys#size bv)]
         [s (##sys#make-string n)] )
    (##core#inline "C_copy_memory" s bv n) 
    s) )

(define (blob=? b1 b2)
  (##sys#check-blob b1 'blob=?)
  (##sys#check-blob b2 'blob=?)
  (let ((n (##sys#size b1)))
    (and (eq? (##sys#size b2) n)
	 (zero? (##core#inline "C_string_compare" b1 b2 n)))))


;;; 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 (##sys#make-vector size . fill)
  (##sys#check-exact size 'make-vector)
  (cond-expand [unsafe] [else (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 make-vector ##sys#make-vector)

(define (list->vector lst0)
  (cond-expand
    [unsafe
    (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)) ) ) ) )]
    [else
    (if (not (list? lst0))
      (##sys#not-a-proper-list-error 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
  (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 vector
  (lambda 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) ) ) )

(define vector-copy!
  (lambda (from to . n)
    (##sys#check-vector from 'vector-copy!)
    (##sys#check-vector to 'vector-copy!)
    (let* ([len-from (##sys#size from)]
	   [len-to (##sys#size to)] 
	   [n (if (pair? n) (car n) (fxmin len-to len-from))] )
      (##sys#check-exact n 'vector-copy!)
      (cond-expand
       [(not unsafe)
	(when (or (fx> n len-to) (fx> n len-from))
	  (##sys#signal-hook 
	   #:bounds-error 'vector-copy!
	   "can not copy vector - count exceeds length" from to n) ) ]
       [else] )
      (do ([i 0 (fx+ i 1)])
	  ((fx>= i n))
	(##sys#setslot to i (##sys#slot from i)) ) ) ) )

(define (vector-resize v n #!optional init)
  (##sys#check-vector v 'vector-resize)
  (##sys#check-exact n 'vector-resize)
  (##sys#grow-vector v n init) )

(define ##sys#grow-vector 
  (lambda (v n init)
    (let ([v2 (##sys#make-vector n init)]
	  [len (##sys#size v)] )
      (do ([i 0 (fx+ i 1)])
	  ((fx>= i len) v2)
	(##sys#setslot v2 i (##sys#slot v i)) ) ) ) )
	

;;; 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-exact n 'integer->char)
  (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )

(define (char=? c1 c2)
  (##sys#check-char c1 'char=?)
  (##sys#check-char c2 'char=?)
  (eq? c1 c2) )

(define (char>? c1 c2)
  (##sys#check-char c1 'char>?)
  (##sys#check-char c2 'char>?)
  (fx> c1 c2) )

(define (char<? c1 c2)
  (##sys#check-char c1 'char<?)
  (##sys#check-char c2 'char<?)
  (fx< c1 c2) )

(define (char>=? c1 c2)
  (##sys#check-char c1 'char>=?)
  (##sys#check-char c2 'char>=?)
  (fx>= c1 c2) )

(define (char<=? c1 c2)
  (##sys#check-char c1 'char<=?)
  (##sys#check-char c2 'char<=?)
  (fx<= c1 c2) )

(define (char-upcase c)
  (##sys#check-char c 'char-upcase)
  (##core#inline "C_make_character"
	     (##core#inline toupper (##core#inline "C_character_code" c)) ) )

(define (char-downcase c)
  (##sys#check-char c 'char-downcase)
  (##core#inline "C_make_character"
	     (##core#inline tolower (##core#inline "C_character_code" c)) ) )

(define char-ci=?)
(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) (fx> (char-downcase x) (char-downcase y))))
  (set! char-ci<? (lambda (x y) (fx< (char-downcase x) (char-downcase y))))
  (set! char-ci>=? (lambda (x y) (fx>= (char-downcase x) (char-downcase y))))
  (set! char-ci<=? (lambda (x y) (fx<= (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) )

(define char-name
  (let ([chars-to-names (make-vector char-name-table-size '())]
	[names-to-chars '()] )
    (define (lookup-char c)
      (let* ([code (char->integer c)]
	     [key (##core#inline "C_fixnum_modulo" code char-name-table-size)] )
	(let loop ([b (##sys#slot chars-to-names key)])
	  (and (pair? b)
	       (let ([a (##sys#slot b 0)])
		 (if (eq? (##sys#slot a 0) c)
		     a
		     (loop (##sys#slot b 1)) ) ) ) ) ) )
    (lambda (x . y)
      (let ([chr (if (pair? y) (car y) #f)])
	(cond [(char? x)
	       (and-let* ([a (lookup-char x)])
		 (##sys#slot a 1) ) ]
	      [chr
	       (##sys#check-symbol x 'char-name)
	       (##sys#check-char chr 'char-name)
	       (when (fx< (##sys#size (##sys#slot x 1)) 2)
		 (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )
	       (let ([a (lookup-char chr)])
		 (if a 
		     (let ([b (assq x names-to-chars)])
		       (##sys#setslot a 1 x)
		       (if b
			   (##sys#setislot b 1 chr)
			   (set! names-to-chars (cons (cons x chr) names-to-chars)) ) )
		     (let ([key (##core#inline "C_fixnum_modulo" (char->integer chr) char-name-table-size)])
		       (set! names-to-chars (cons (cons x chr) names-to-chars))
		       (##sys#setslot 
			chars-to-names key
			(cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ]
	      [else
	       (##sys#check-symbol x 'char-name)
	       (and-let* ([a (assq x names-to-chars)])
		 (##sys#slot a 1) ) ] ) ) ) ) )

(char-name 'space #\space)
(char-name 'tab #\tab)
(char-name 'linefeed #\linefeed)
(char-name 'newline #\newline)
(char-name 'vtab (integer->char 11))
(char-name 'delete (integer->char 127))
(char-name 'esc (integer->char 27))
(char-name 'alarm (integer->char 7))
(char-name 'nul (integer->char 0))
(char-name 'return #\return)
(char-name 'page (integer->char 12))
(char-name 'backspace (integer->char 8))


;;; 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-direct-continuation k) (##core#app k (##core#inline "C_direct_continuation" #f)))
(define ##sys#call-with-cthulhu (##core#primitive "C_call_with_cthulhu"))
(define (##sys#direct-return dk x) (##core#inline "C_direct_return" dk x))
(define values (##core#primitive "C_values"))
(define ##sys#call-with-values (##core#primitive "C_call_with_values"))
(define call-with-values ##sys#call-with-values)

(define (##sys#for-each p lst0)
  (let loop ((lst lst0))
    (cond-expand
     [unsafe
      (if (eq? lst '()) 
	  (##core#undefined)
	  (begin
	    (p (##sys#slot lst 0))
	    (loop (##sys#slot lst 1)) ) ) ]
     [else
      (cond ((eq? lst '()) (##core#undefined))
	    ((pair? lst)
	     (p (##sys#slot lst 0))
	     (loop (##sys#slot lst 1)) )
	    (else (##sys#not-a-proper-list-error lst0 'for-each)) ) ] ) ) )

(define (##sys#map p lst0)
  (let loop ((lst lst0))
    (cond-expand
     [unsafe
      (if (eq? lst '()) 
	  lst
	  (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) ) ]
     [else
      (cond ((eq? lst '()) lst)
	    ((pair? lst)
	     (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )
	    (else (##sys#not-a-proper-list-error lst0 'map)) ) ] ) ) )

(define for-each)
(define map)

(let ([car car]
      [cdr cdr] )
  (letrec ((mapsafe
	    (lambda (p lsts start loc)
	      (if (eq? lsts '())
		  lsts
		  (let ((item (##sys#slot lsts 0)))
		    (cond ((eq? item '())
			   (cond-expand [unsafe (##core#undefined)]
					[else (check lsts start loc)] ) )
			  ((pair? item)
			   (cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
			  (else (##sys#not-a-proper-list-error item loc)) ) ) ) ) )
	   (check 
	    (lambda (lsts start loc)
	      (if (or (not start)
		      (let loop ((lsts lsts))
			(and (not (eq? lsts '()))
			     (not (eq? (##sys#slot lsts 0) '()))
			     (loop (##sys#slot lsts 1)) ) ) )
		  (##sys#error loc "lists are not of same length" lsts) ) ) ) )

    (set! for-each