library.scm

Scheme跨平台编译器

	  (lambda (fn lst1 . lsts)
	    (if (null? lsts)
		(##sys#for-each fn lst1)
		(let loop ((all (cons lst1 lsts)))
		  (let ((first (##sys#slot all 0)))
		    (cond ((pair? first)
			   (apply fn (mapsafe car all #t 'for-each))
			   (loop (mapsafe cdr all #t 'for-each)) )
			  (else (check all #t 'for-each)) ) ) ) ) ) )

    (set! map
	  (lambda (fn lst1 . lsts)
	    (if (null? lsts)
		(##sys#map fn lst1)
		(let loop ((all (cons lst1 lsts)))
		  (let ((first (##sys#slot all 0)))
		    (cond ((pair? first)
			   (cons (apply fn (mapsafe car all #t 'map))
				 (loop (mapsafe cdr all #t 'map)) ) )
			  (else (check (##core#inline "C_i_cdr" all) #t 'map)
				'() ) ) ) ) ) ) ) ) )


;;; dynamic-wind:
;
; (taken more or less directly from SLIB)
;
; This implementation is relatively costly: we have to shadow call/cc
; with a new version that unwinds suspended thunks, but for this to
; happen the return-values of the escaping procedure have to be saved
; temporarily in a list. Since call/cc is very efficient under this
; implementation, and because allocation of memory that is to be
; garbage soon has also quite low overhead, the performance-penalty
; might be acceptable (ctak needs about 4 times longer).

(define ##sys#dynamic-winds '())

(define dynamic-wind
  (lambda (before thunk after)
    (before)
    (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
    (##sys#call-with-values
     thunk
     (lambda results
       (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
       (after)
       (apply ##sys#values results) ) ) ) )

(define ##sys#dynamic-wind dynamic-wind)

(define call-with-current-continuation
  (lambda (proc)
    (let ((winds ##sys#dynamic-winds))
      (##sys#call-with-current-continuation
       (lambda (cont)
	 (proc
	  (lambda results
	    (unless (eq? ##sys#dynamic-winds winds)
	      (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
	    (apply cont results) ) ) ) ) ) ) )

(define call/cc call-with-current-continuation)

(define (##sys#dynamic-unwind winds n)
  (cond [(eq? ##sys#dynamic-winds winds)]
	[(fx< n 0)
	 (##sys#dynamic-unwind (##sys#slot winds 1) (fx+ n 1))
	 ((##sys#slot (##sys#slot winds 0) 0))
	 (set! ##sys#dynamic-winds winds) ]
	[else
	 (let ([after (##sys#slot (##sys#slot ##sys#dynamic-winds 0) 1)])
	   (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
	   (after)
	   (##sys#dynamic-unwind winds (fx- n 1)) ) ] ) )

(define (continuation-capture proc)
  (let ([winds ##sys#dynamic-winds]
	[k (##core#inline "C_direct_continuation" #f)] )
    (proc (##sys#make-structure 'continuation k winds))) )

(define (continuation? x)
  (##sys#structure? x 'continuation) )

(define ##sys#continuation-graft (##core#primitive "C_continuation_graft"))

(define (continuation-graft k thunk)
  (##sys#check-structure k 'continuation 'continuation-graft)
  (let ([winds (##sys#slot k 2)])
    (unless (eq? ##sys#dynamic-winds winds)
      (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
    (##sys#continuation-graft k thunk) ) )

(define continuation-return
  (let ([continuation-graft continuation-graft])
    (lambda (k . vals)
      (##sys#check-structure k 'continuation 'continuation-return)
      (continuation-graft k (lambda () (apply values vals))) ) ) )


;;; Ports:

(define (port? x) (##core#inline "C_i_portp" x))

(define (input-port? x)
  (and (##core#inline "C_blockp" x)
       (##core#inline "C_portp" x)
       (##sys#slot x 1) ) )

(define (output-port? x)
  (and (##core#inline "C_blockp" x)
       (##core#inline "C_portp" x)
       (not (##sys#slot x 1)) ) )

;;; Port layout:
;
; 0:  FP (special)
; 1:  input/output (bool)
; 2:  class (vector of procedures)
; 3:  name (string)
; 4:  row (fixnum)
; 5:  col (fixnum)
; 6:  EOF (bool)
; 7:  type ('stream | 'custom | 'string | 'socket)
; 8:  closed (bool)
; 9:  data
; 10-15: reserved, port class specific
;
; Port-class:
;
; 0:  (read-char PORT) -> CHAR | EOF
; 1:  (peek-char PORT) -> CHAR | EOF
; 2:  (write-char PORT CHAR)
; 3:  (write-string PORT STRING)
; 4:  (close PORT)
; 5:  (flush-output PORT)
; 6:  (char-ready? PORT) -> BOOL
; 7:  (read-string! PORT COUNT STRING START) -> COUNT'
; 8:  (read-line PORT LIMIT) -> STRING | EOF

(define (##sys#make-port i/o class name type)
  (let ([port (##core#inline_allocate ("C_a_i_port" 17))])
    (##sys#setislot port 1 i/o)
    (##sys#setslot port 2 class)
    (##sys#setslot port 3 name)
    (##sys#setislot port 4 1)
    (##sys#setislot port 5 0)
    (##sys#setslot port 7 type)
    port) )

(define ##sys#stream-port-class
  (vector (lambda (p)			; read-char
	    (##core#inline "C_read_char" p) )
	  (lambda (p)			; peek-char
	    (##core#inline "C_peek_char" p) )
	  (lambda (p c)			; write-char
	    (##core#inline "C_display_char" p c) )
	  (lambda (p s)			; write-string
	    (##core#inline "C_display_string" p s) )
	  (lambda (p)	    		; close
	    (##core#inline "C_close_file" p)
	    (##sys#update-errno) )
	  (lambda (p)			; flush-output
	    (##core#inline "C_flush_output" p) )
	  (lambda (p)			; char-ready?
	    (##core#inline "C_char_ready_p" p) )
	  #f				; read-string!
	  #; ;UNUSED
          (lambda (p n dest start)      ; read-string!
            (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
              (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
                (cond [(eof-object? len)
                        (if (eq? 0 act) #!eof act)]
                      [(not len)
                        act]
                      [(fx< len rem)
                        (loop (fx- rem len) (fx+ act len) (fx+ start len))]
                      [else
                        act ] ) ) ) )
	  (lambda (p limit)		; read-line
	    (let* ((buffer-len (if limit limit 256))
		   (buffer (make-string buffer-len)))
	      (let loop ([len buffer-len]
			 [buffer buffer]
			 [result ""]
			 [f #f])
		(let ([n (##core#inline "fast_read_line_from_file" buffer p len)])
		  (cond [(eof-object? n) (if f result #!eof)]
			[(and limit (not n))
			 (##sys#string-append result (##sys#substring buffer 0 limit))]
			[(not n)
			 (loop (fx* len 2) (##sys#make-string (fx* len 2))
			       (##sys#string-append 
				result
				(##sys#substring buffer 0 len))
			       #t) ]
			[f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
			   (##sys#string-append result (##sys#substring buffer 0 n))]
			[else
			 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
			 (##sys#substring buffer 0 n)] ) ) ) ) ) ) )

(define ##sys#open-file-port (##core#primitive "C_open_file_port"))

(define ##sys#standard-input (##sys#make-port #t ##sys#stream-port-class "(stdin)" 'stream))
(define ##sys#standard-output (##sys#make-port #f ##sys#stream-port-class "(stdout)" 'stream))
(define ##sys#standard-error (##sys#make-port #f ##sys#stream-port-class "(stderr)" 'stream))

(##sys#open-file-port ##sys#standard-input 0 #f)
(##sys#open-file-port ##sys#standard-output 1 #f)
(##sys#open-file-port ##sys#standard-error 2 #f)

(define ##sys#check-port
  (lambda (x . loc)
    (if (or (not (##core#inline "C_blockp" x))
	    (not (##core#inline "C_portp" x)) )
	(##sys#signal-hook #:type-error (if (pair? loc) (car loc) #f) "argument is not a port" x) ) ) )

(define ##sys#check-port-mode
  (lambda (port mode . loc)
    (unless (eq? mode (##sys#slot port 1))
      (##sys#signal-hook 
       #:type-error (if (pair? loc) (car loc) #f)
       (if mode "port is not an input port" "port is not an output-port") ) ) ) )

(define (##sys#check-port* p loc)
  (##sys#check-port p)
  (when (##sys#slot p 8)
    (##sys#signal-hook #:file-error loc "port already closed" p) )
  p)

(define (current-input-port . arg)
  (if (pair? arg)
      (let ([p (car arg)])
	(##sys#check-port p 'current-input-port)
	(set! ##sys#standard-input p) )
      ##sys#standard-input) )

(define (current-output-port . arg)
  (if (pair? arg)
      (let ([p (car arg)])
	(##sys#check-port p 'current-output-port)
	(set! ##sys#standard-output p) )
      ##sys#standard-output) )

(define (current-error-port . arg)
  (if (pair? arg)
      (let ([p (car arg)])
	(##sys#check-port p 'current-error-port)
	(set! ##sys#standard-error p) )
      ##sys#standard-error) )

(define (##sys#tty-port? port)
  (and (not (zero? (##sys#peek-unsigned-integer port 0)))
       (##core#inline "C_tty_portp" port) ) )

(define (##sys#port-data port) (##sys#slot port 9))

(define ##sys#platform-fixup-pathname
  (let* ([bp (string->symbol ((##core#primitive "C_build_platform")))]
	 [fixsuffix (eq? bp 'mingw32)])
    (lambda (name)
      (if fixsuffix
        (let ([end (fx- (##sys#size name) 1)])
          (if (fx>= end 0)
            (let ([c (##core#inline "C_subchar" name end)])
              (if (or (eq? c #\\) (eq? c #\/))
                (##sys#substring name 0 end)
                name) )
            name) )
        name) ) ) )

(define (##sys#pathname-resolution name thunk . _)
  (thunk (##sys#expand-home-path name)) )

(define ##sys#expand-home-path
  (let ((getenv getenv))
    (lambda (path)
      (let ((len (##sys#size path)))
	(if (fx> len 0)
	    (case (##core#inline "C_subchar" path 0)
	      ((#\~) 
	       (let ((rest (##sys#substring path 1 len)))
		 (if (and (fx> len 1) (char=? #\/ (##core#inline "C_subchar" path 1)))
		     (##sys#string-append (or (getenv "HOME") "") rest)
		     (##sys#string-append "/home/" rest) ) ) )
	      ((#\$) 
	       (let loop ((i 1))
		 (if (fx>= i len)
		     path
		     (let ((c (##core#inline "C_subchar" path i)))
		       (if (or (eq? c #\/) (eq? c #\\))
			   (##sys#string-append
			    (or (getenv (##sys#substring path 1 i)) "")
			    (##sys#substring path i len))
			   (loop (fx+ i 1)) ) ) ) ) )
	      (else path) )
	    "") ) ) ) )

(define open-input-file)
(define open-output-file)
(define close-input-port)
(define close-output-port)

(let ()
 
  (define (open name inp modes loc)
    (##sys#check-string name loc)
    (##sys#pathname-resolution
     name
     (lambda (name)
       (let ([fmode (if inp "r" "w")]
	     [bmode ""] )
	 (do ([modes modes (##sys#slot modes 1)])
	     ((null? modes))
	   (let ([o (##sys#slot modes 0)])
	     (case o
	       [(#:binary) (set! bmode "b")]
	       [(#:text) (set! bmode "")]
	       [(#:append) 
		(if inp
		    (##sys#error loc "can not use append mode with input file")
		    (set! fmode "a") ) ]
	       [else (##sys#error loc "invalid file option" o)] ) ) )
	 (let ([port (##sys#make-port inp ##sys#stream-port-class name 'stream)])
	   (unless (##sys#open-file-port port name (##sys#string-append fmode bmode))
	     (##sys#update-errno)
	     (##sys#signal-hook #:file-error loc (##sys#string-append "can not open file - " strerror) name) )
	   port) ) )
     #:open (not inp) modes) )

  (define (close port loc)
    (##sys#check-port port loc)
    (unless (##sys#slot port 8)		; closed?
      ((##sys#slot (##sys#slot port 2) 4) port) ; close
      (##sys#setislot port 8 #t) )
    (##core#undefined) )

  (set! open-input-file (lambda (name . mode) (open name #t mode 'open-input-file)))
  (set! open-output-file (lambda (name . mode) (open name #f mode 'open-output-file)))
  (set! close-input-port (lambda (port) (close port 'close-input-port)))
  (set! close-output-port (lambda (port) (close port 'close-output-port))) )

(define call-with-input-file
  (let ([open-input-file open-input-file]
	[close-input-port close-input-port] )
    (lambda (name p . mode)
      (let ([f (apply open-input-file name mode)])
	(##sys#call-with-values
	 (lambda () (p f))
	 (lambda results
	   (close-input-port f)
	   (apply ##sys#values results) ) ) ) ) ) )

(define call-with-output-file
  (let ([open-output-file open-output-file]
	[close-output-port close-output-port] )
    (lambda (name p . mode)
      (let ([f (apply open-output-file name mode)])
	(##sys#call-with-values
	 (lambda () (p f))
	 (lambda results
	   (close-output-port f)
	   (apply ##sys#values results) ) ) ) ) ) )

(define with-input-from-file 
  (let ((open-input-file open-input-file)
	(close-input-port close-input-port) )
    (lambda (str thunk . mode)
      (let ((old ##sys#standard-input)
	    (file (apply open-input-file str mode)) )
	(set! ##sys#standard-input file)
	(##sys#call-with-values thunk
	  (lambda results
	    (close-input-port file)
	    (set! ##sys#standard-input old)
	    (apply ##sys#values results) ) ) ) ) ) )

(define with-output-to-file 
  (let ((open-output-file open-output-file)
	(close-output-port close-output-port) ) 
    (lambda (str thunk . mode)
      (let ((old ##sys#standard-output)
	    (file (apply open-output-file str mode)) )
	(set! ##sys#standard-output file)
	(##sys#call-with-values thunk
	  (lambda results
	    (close-output-port file)
	    (set! ##sys#standard-output old)
	    (apply ##sys#values results) ) ) ) ) ) )

(define (file-exists?