data-structures.scm

Scheme跨平台编译器

;;; data-structures.scm - Optional data structures extensions
;
; 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 data-structures)
 (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 data-structures
  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 "data-structures.exports")) ] )

(register-feature! 'data-structures)



;;; Combinators:

(define (identity x) x)

(define (project n)
  (lambda args (list-ref args n)) )

(define (conjoin . preds)
  (lambda (x)
    (let loop ([preds preds])
      (or (null? preds)
	  (and ((##sys#slot preds 0) x)
	       (loop (##sys#slot preds 1)) ) ) ) ) )

(define (disjoin . preds)
  (lambda (x)
    (let loop ([preds preds])
      (and (not (null? preds))
	   (or ((##sys#slot preds 0) x)
	       (loop (##sys#slot preds 1)) ) ) ) ) )

(define (constantly . xs)
  (if (eq? 1 (length xs))
      (let ([x (car xs)])
	(lambda _ x) )
      (lambda _ (apply values xs)) ) )

(define (flip proc) (lambda (x y) (proc y x)))

(define complement
  (lambda (p)
    (lambda args (not (apply p args))) ) )

(define (compose . fns)
  (define (rec f0 . fns)
    (if (null? fns)
	f0
	(lambda args
	  (call-with-values
	      (lambda () (apply (apply rec fns) args))
	    f0) ) ) )
  (if (null? fns)
      values
      (apply rec fns) ) )

(define (o . fns)
  (if (null? fns)
      identity
      (let loop ((fns fns))
	(let ((h (##sys#slot fns 0))
	      (t (##sys#slot fns 1)) )
	  (if (null? t)
	      h
	      (lambda (x) (h ((loop t) x))))))))

(define (list-of pred)
  (lambda (lst)
    (let loop ([lst lst])
      (cond [(null? lst) #t]
	    [(not-pair? lst) #f]
	    [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
	    [else #f] ) ) ) )

(define (noop . _) (void))

(define (each . procs)
  (cond ((null? procs) (lambda _ (void)))
	((null? (##sys#slot procs 1)) (##sys#slot procs 0))
	(else
	 (lambda args
	   (let loop ((procs procs))
	     (let ((h (##sys#slot procs 0))
		   (t (##sys#slot procs 1)) )
	       (if (null? t)
		   (apply h args)
		   (begin
		     (apply h args)
		     (loop t) ) ) ) ) ) ) ) )

(define (any? x) #t)

(define (none? x) #f)

(define (always? . _) #t)

(define (never? . _) #f)

(define (left-section proc . args)
  (##sys#check-closure proc 'left-section)
  (lambda xs
    (##sys#apply proc (##sys#append args xs)) ) )

(define right-section
  (let ([##sys#reverse reverse])
    (lambda (proc . args)
      (##sys#check-closure proc 'right-section)
      (let ([revdargs (##sys#reverse args)])
        (lambda xs
          (##sys#apply proc (##sys#reverse (##sys#append revdargs (##sys#reverse xs)))) ) ) ) ) )


;;; List operators:

(define (atom? x) (##core#inline "C_i_not_pair_p" x))

(define (tail? x y)
  (##sys#check-list y 'tail?)
  (or (##core#inline "C_eqp" x '())
      (let loop ((y y))
	(cond ((##core#inline "C_eqp" y '()) #f)
	      ((##core#inline "C_eqp" x y) #t)
	      (else (loop (##sys#slot y 1))) ) ) ) )

(define intersperse 
  (lambda (lst x)
    (let loop ((ns lst))
      (if (##core#inline "C_eqp" ns '())
	  ns
	  (let ((tail (cdr ns)))
	    (if (##core#inline "C_eqp" tail '())
		ns
		(cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )

(define (butlast lst)
  (##sys#check-pair lst 'butlast)
  (let loop ((lst lst))
    (let ((next (##sys#slot lst 1)))
      (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
	  (cons (##sys#slot lst 0) (loop next))
	  '() ) ) ) )

(define (flatten . lists0)
  (let loop ([lists lists0] [rest '()])
    (cond [(null? lists) rest]
	  [else
	   (let ([head (##sys#slot lists 0)]
		 [tail (##sys#slot lists 1)] )
	     (if (list? head)
		 (loop head (loop tail rest))
		 (cons head (loop tail rest)) ) ) ] ) ) )

(define chop
  (let ([reverse reverse])
    (lambda (lst n)
      (##sys#check-exact n 'chop)
      (cond-expand
       [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
       [else] )
      (let ([len (length lst)])
	(let loop ([lst lst] [i len])
	  (cond [(null? lst) '()]
		[(fx< i n) (list lst)]
		[else
		 (do ([hd '() (cons (##sys#slot tl 0) hd)]
		      [tl lst (##sys#slot tl 1)] 
		      [c n (fx- c 1)] )
		     ((fx= c 0)
		      (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )

(define (join lsts . lst)
  (let ([lst (if (pair? lst) (car lst) '())])
    (##sys#check-list lst 'join)
    (let loop ([lsts lsts])
      (cond [(null? lsts) '()]
	    [(cond-expand [unsafe #f] [else (not (pair? lsts))])
	     (##sys#not-a-proper-list-error lsts) ]
	    [else
	     (let ([l (##sys#slot lsts 0)]
		   [r (##sys#slot lsts 1)] )
	       (if (null? r)
		   l
		   (##sys#append l lst (loop r)) ) ) ] ) ) ) )

(define compress
  (lambda (blst lst)
    (let ([msg "bad argument type - not a proper list"])
      (##sys#check-list lst 'compress)
      (let loop ([blst blst] [lst lst])
	(cond [(null? blst) '()]
	      [(cond-expand [unsafe #f] [else (not (pair? blst))])
	       (##sys#signal-hook #:type-error 'compress msg blst) ]
	      [(cond-expand [unsafe #f] [else (not (pair? lst))])
	       (##sys#signal-hook #:type-error 'compress msg lst) ]
	      [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
	      [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )

(define shuffle
  ;; this should really shadow SORT! and RANDOM...
  (lambda (l random)
    (let ((len (length l)))
      (map cdr
	   (sort! (map (lambda (x) (cons (random len) x)) l)
		  (lambda (x y) (< (car x) (car y)))) ) ) ) )


;;; Alists:

(define (alist-update! x y lst . cmp)
  (let* ([cmp (if (pair? cmp) (car cmp) eqv?)]
	 [aq (cond [(eq? eq? cmp) assq]
		   [(eq? eqv? cmp) assv]
		   [(eq? equal? cmp) assoc]
		   [else 
		    (lambda (x lst)
		      (let loop ([lst lst])
			(and (pair? lst)
			     (let ([a (##sys#slot lst 0)])
			       (if (and (pair? a) (cmp (##sys#slot a 0) x))
				   a
				   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
	 [item (aq x lst)] )
    (if item
	(begin
	  (##sys#setslot item 1 y)
	  lst)
	(cons (cons x y) lst) ) ) )

(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
  (let* ([aq (cond [(eq? eq? cmp) assq]
		   [(eq? eqv? cmp) assv]
		   [(eq? equal? cmp) assoc]
		   [else 
		    (lambda (x lst)
		      (let loop ([lst lst])
			(and (pair? lst)
			     (let ([a (##sys#slot lst 0)])
			       (if (and (pair? a) (cmp (##sys#slot a 0) x))
				   a
				   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
	 [item (aq x lst)] )
    (if item
	(##sys#slot item 1)
	default) ) )

(define (rassoc x lst . tst)
  (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
  (let ([tst (if (pair? tst) (car tst) eqv?)])
    (let loop ([l lst])
      (and (pair? l)
	   (let ([a (##sys#slot l 0)])
	     (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
	     (if (tst x (##sys#slot a 1))
		 a
		 (loop (##sys#slot l 1)) ) ) ) ) ) )



; (reverse-string-append l) = (apply string-append (reverse l))

(define (reverse-string-append l)

  (define (rev-string-append l i)
    (if (pair? l)
      (let* ((str (car l))
	     (len (string-length str))
	     (result (rev-string-append (cdr l) (+ i len))))
	(let loop ((j 0) (k (- (- (string-length result) i) len)))
	  (if (< j len)
	    (begin
	      (string-set! result k (string-ref str j))
	      (loop (+ j 1) (+ k 1)))
	    result)))
      (make-string i)))

  (rev-string-append l 0))

;;; Anything->string conversion:

(define ->string 
  (let ([open-output-string open-output-string]
	[display display]
	[string string]
	[get-output-string get-output-string] )
    (lambda (x)
      (cond [(string? x) x]
	    [(symbol? x) (symbol->string x)]
	    [(char? x) (string x)]
	    [(number? x) (##sys#number->string x)]
	    [else 
	     (let ([o (open-output-string)])
	       (display x o)
	       (get-output-string o) ) ] ) ) ) )

(define conc
  (let ([string-append string-append])
    (lambda args
      (apply string-append (map ->string args)) ) ) )


;;; Search one string inside another:

(let ()
  (define (traverse which where start test loc)
    (##sys#check-string which loc)
    (##sys#check-string where loc)
    (let ([wherelen (##sys#size where)]
	  [whichlen (##sys#size which)] )
      (##sys#check-exact start loc)
      (let loop ([istart start] [iend whichlen])
	(cond [(fx> iend wherelen) #f]
	      [(test istart whichlen) istart]
	      [else 
	       (loop (fx+ istart 1)
		     (fx+ iend 1) ) ] ) ) ) )
  (set! ##sys#substring-index 
    (lambda (which where start)
      (traverse 
       which where start
       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
       'substring-index) ) )
  (set! ##sys#substring-index-ci 
    (lambda (which where start)
      (traverse
       which where start
       (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
       'substring-index-ci) ) ) )

(define (substring-index which where #!optional (start 0))
  (##sys#substring-index which where start) )

(define (substring-index-ci which where #!optional (start 0))
  (##sys#substring-index-ci which where start) )


;;; 3-Way string comparison:

(define (string-compare3 s1 s2)
  (##sys#check-string s1 'string-compare3)
  (##sys#check-string s2 'string-compare3)
  (let ((len1 (##sys#size s1))
	(len2 (##sys#size s2)) )
    (let* ((len-diff (fx- len1 len2)) 
	   (cmp (##core#inline "C_mem_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
      (if (fx= cmp 0) 
	  len-diff 
	  cmp))))

(define (string-compare3-ci s1 s2)
  (##sys#check-string s1 'string-compare3-ci)
  (##sys#check-string s2 'string-compare3-ci)
  (let ((len1 (##sys#size s1))
	(len2 (##sys#size s2)) )
    (let* ((len-diff (fx- len1 len2)) 
	   (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
      (if (fx= cmp 0) 
	  len-diff 
	  cmp))))


;;; Substring comparison:

(define (##sys#substring=? s1 s2 start1 start2 n)
  (##sys#check-string s1 'substring=?)
  (##sys#check-string s2 'substring=?)
  (let ((len (or n
		 (fxmin (fx- (##sys#size s1) start1)
			(fx- (##sys#size s2) start2) ) ) ) )
    (##sys#check-exact start1 'substring=?)
    (##sys#check-exact start2 'substring=?)
    (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )

(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
  (##sys#substring=? s1 s2 start1 start2 len) )

(define (##sys#substring-ci=? s1 s2 start1 start2 n)
  (##sys#check-string s1 'substring-ci=?)
  (##sys#check-string s2 'substring-ci=?)
  (let ((len (or n
		 (fxmin (fx- (##sys#size s1) start1)
			(fx- (##sys#size s2) start2) ) ) ) )
    (##sys#check-exact start1 'substring-ci=?)