extras.scm

Scheme跨平台编译器

;;; extras.scm - Optional non-standard extensions
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare
 (unit extras)
 (uses data-structures ports)
 (usual-integrations)
 (disable-warning redef)
 (foreign-declare #<<EOF
#define C_mem_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
EOF
) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
      ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
      ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
      ##sys#allocate-vector ##sys#check-pair ##sys#not-a-proper-list-error
      ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
      ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
      ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
      ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
      ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
      ##sys#flush-output ##sys#write-char-0 ##sys#number->string
      ##sys#fragments->string ##sys#symbol->qualified-string
      ##extras#reverse-string-append ##sys#number? ##sys#procedure->string
      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
      input-port? make-vector list->vector sort! merge! open-output-string floor
      get-output-string current-output-port display write port? list->string
      make-string string pretty-print-width newline char-name read random
      open-input-string make-string call-with-input-file read-line reverse ) ) ] )

(private extras
  reverse-string-append
  fprintf0 generic-write )

(declare
  (hide
    fprintf0 generic-write ) )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-closure . _) '(##core#undefined))
    (define-macro (##sys#check-inexact . _) '(##core#undefined))
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "extras.exports")) ] )

(register-feature! 'extras)

;;; Read expressions from file:

(define read-file
  (let ([read read]
	[reverse reverse] 
	[call-with-input-file call-with-input-file] )
    (lambda (#!optional (port ##sys#standard-input) (reader read) max)
      (define (slurp port)
	(do ((x (reader port) (reader port))
	     (i 0 (fx+ i 1))
	     (xs '() (cons x xs)) )
	    ((or (eof-object? x) (and max (fx>= i max))) (reverse xs)) ) )
      (if (port? port)
	  (slurp port)
	  (call-with-input-file port slurp) ) ) ) )



;;; Random numbers:

(define random-seed
    (let ((srand   (foreign-lambda void "srand" unsigned-integer)))
        (lambda n
            (and (> (length n) 1)
                 (##sys#error 'random-seed "too many arguments" (length n) 1))
            (let ((t   (if (null? n)
                           (current-seconds)
                           (car n))))
                (##sys#check-integer t 'random-seed)
                (srand t)))))

(define (random n)
  (##sys#check-exact n 'random)
  (if (eq? n 0)
      0
      (##core#inline "C_random_fixnum" n) ) )

(define (randomize . n)
  (##core#inline
   "C_randomize"
   (if (##core#inline "C_eqp" n '())
       (##sys#fudge 2)
       (let ((nn (##sys#slot n 0)))
	 (##sys#check-exact nn 'randomize)
	 nn) ) ) )


;;; Line I/O:

(define read-line
  (let ([make-string make-string])
    (define (fixup str len)
      (##sys#substring
       str 0
       (if (and (fx>= len 1) (char=? #\return (##core#inline "C_subchar" str (fx- len 1))))
	   (fx- len 1)
	   len) ) )
    (lambda args
      (let* ([parg (pair? args)]
	     [p (if parg (car args) ##sys#standard-input)]
	     [limit (and parg (pair? (cdr args)) (cadr args))])
	(##sys#check-port p 'read-line)
	(cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
	      (else
	       (let* ((buffer-len (if limit limit 256))
		      (buffer (##sys#make-string buffer-len)))
		 (let loop ([i 0])
		   (if (and limit (fx>= i limit))
		       (##sys#substring buffer 0 i)
		       (let ([c (##sys#read-char-0 p)])
			 (if (eof-object? c)
			     (if (fx= i 0)
				 c
				 (##sys#substring buffer 0 i) ) 
			     (case c
			       [(#\newline) (##sys#substring buffer 0 i)]
			       [(#\return)
				(let ([c (peek-char p)])
				  (if (char=? c #\newline)
				      (begin (##sys#read-char-0 p)
					     (##sys#substring buffer 0 i))
				      (##sys#substring buffer 0 i) ) ) ]
			       [else
				(when (fx>= i buffer-len)
				  (set! buffer (##sys#string-append buffer (make-string buffer-len)))
				  (set! buffer-len (fx+ buffer-len buffer-len)) )
				(##core#inline "C_setsubchar" buffer i c)
				(loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )

(define read-lines
  (let ((read-line read-line)
	(call-with-input-file call-with-input-file) 
	(reverse reverse) )
    (lambda port-and-max
      (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
	     (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
	     (max (if (pair? rest) (##sys#slot rest 0) #f)) )
	(define (doread port)
	  (let loop ((lns '())
		     (n (or max 1000000000)) ) ; this is silly
	    (if (eq? n 0)
		(reverse lns)
		(let ((ln (read-line port)))
		  (if (eof-object? ln)
		      (reverse lns)
		      (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
	(if (string? port)
	    (call-with-input-file port doread)
	    (begin
	      (##sys#check-port port 'read-lines)
	      (doread port) ) ) ) ) ) )


;;; Extended I/O 

(define (##sys#read-string! n dest port start)
  (cond ((eq? n 0) 0)
	(else
	 (when (##sys#slot port 6)	; peeked?
	   (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
	   (set! start (fx+ start 1)) )
	 (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
	   (let loop ((start start) (n n) (m 0))
	     (let ((n2 (if rdstring
			   (rdstring port n dest start) ; *** doesn't update port-position!
			   (let ((c (##sys#read-char-0 port)))
			     (if (eof-object? c)
				 0
				 (begin
				   (##core#inline "C_setsubchar" dest start c)
				   1) ) ) ) ) )
	       (cond ((eq? n2 0) m)
		     ((or (not n) (fx< n2 n)) 
		      (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
		     (else (fx+ n2 m))) ) ) ))))

(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
  (##sys#check-port port 'read-string!)
  (##sys#check-string dest 'read-string!)
  (when n
    (##sys#check-exact n 'read-string!)
    (when (fx> (fx+ start n) (##sys#size dest))
      (set! n (fx- (##sys#size dest) start))))
  (##sys#check-exact start 'read-string!)
  (##sys#read-string! n dest port start) )

(define ##sys#read-string/port
  (let ((open-output-string open-output-string)
	(get-output-string get-output-string) )
    (lambda (n p)
      (##sys#check-port p 'read-string)
      (cond (n (##sys#check-exact n 'read-string)
	       (let* ((str (##sys#make-string n))
		      (n2 (##sys#read-string! n str p 0)) )
		 (if (eq? n n2)
		     str
		     (##sys#substring str 0 n2))))
	    (else
	     (let ([str (open-output-string)])
	       (let loop ([n n])
		 (or (and (eq? n 0) (get-output-string str))
		     (let ([c (##sys#read-char-0 p)])
		       (if (eof-object? c)
			   (get-output-string str)
			   (begin
			     (##sys#write-char/port c str) 
			     (loop (and n (fx- n 1))) ) ) ) ) ) ) ) ) ) ) )

(define (read-string #!optional n (port ##sys#standard-input))
  (##sys#read-string/port n port) )

(define read-token
  (let ([open-output-string open-output-string]
	[get-output-string get-output-string] )
    (lambda (pred . port)
      (let ([port (:optional port ##sys#standard-input)])
	(##sys#check-port port 'read-token)
	(let ([out (open-output-string)])
	  (let loop ()
	    (let ([c (##sys#peek-char-0 port)])
	      (if (and (not (eof-object? c)) (pred c))
		  (begin
		    (##sys#write-char-0 (##sys#read-char-0 port) out)
		    (loop) )
		  (get-output-string out) ) ) ) ) ) ) ) )

(define write-string 
  (let ([display display])
    (lambda (s . more)
      (##sys#check-string s 'write-string)
      (let-optionals more ([n #f] [port ##sys#standard-output])
	(##sys#check-port port 'write-string)
	(when n (##sys#check-exact n 'write-string))
	(display 
	 (if (and n (fx< n (##sys#size s)))
	     (##sys#substring s 0 n)
	     s)
	 port) ) ) ) )

(define write-line
  (let ((display display)
	(newline newline) )
    (lambda (str . port)
      (let ((p (if (##core#inline "C_eqp" port '())
		   ##sys#standard-output
		   (##sys#slot port 0) ) ) )
	(##sys#check-port p 'write-line)
	(##sys#check-string str 'write-line)
	(display str p)
	(newline p) ) ) ) )


;;; Binary I/O

(define (read-byte #!optional (port ##sys#standard-input))
  (##sys#check-port port 'read-byte)
  (let ((x (##sys#read-char-0 port)))
    (if (eof-object? x)
	x
	(char->integer x) ) ) )

(define (write-byte byte #!optional (port ##sys#standard-output))
  (##sys#check-exact byte 'write-byte)
  (##sys#check-port port 'write-byte)
  (##sys#write-char-0 (integer->char byte) port) )




;;; Pretty print:
;
; Copyright (c) 1991, Marc Feeley
; Author: Marc Feeley ([e-mail])
; Distribution restrictions: none
;
; Modified by felix for use with CHICKEN
;

(define generic-write
  (let ([open-output-string open-output-string]
	[get-output-string get-output-string] )
    (lambda (obj display? width output)

      (define (read-macro? l)
	(define (length1? l) (and (pair? l) (null? (cdr l))))
	(let ((head (car l)) (tail (cdr l)))
	  (case head
	    ((quote quasiquote unquote unquote-splicing) (length1? tail))
	    (else                                        #f))))

      (define (read-macro-body l)
	(cadr l))

      (define (read-macro-prefix l)
	(let ((head (car l)) (tail (cdr l)))
	  (case head
	    ((quote)            "'")
	    ((quasiquote)       "`")
	    ((unquote)          ",")
	    ((unquote-splicing) ",@"))))

      (define (out str col)
	(and col (output str) (+ col (string-length str))))

      (define (wr obj col)

	(define (wr-expr expr col)