srfi-13.scm

Scheme跨平台编译器

    (string-set! s i (proc (string-ref s i)))))

(define (string-fold kons knil s . maybe-start+end)
;  (check-arg procedure? kons string-fold)
  (let-string-start+end (start end) string-fold s maybe-start+end
    (let lp ((v knil) (i start))
      (if (< i end) (lp (kons (string-ref s i) v) (+ i 1))
	  v))))

(define (string-fold-right kons knil s . maybe-start+end)
;  (check-arg procedure? kons string-fold-right)
  (let-string-start+end (start end) string-fold-right s maybe-start+end
    (let lp ((v knil) (i (- end 1)))
      (if (>= i start) (lp (kons (string-ref s i) v) (- i 1))
	  v))))

;;; (string-unfold p f g seed [base make-final])
;;; This is the fundamental constructor for strings. 
;;; - G is used to generate a series of "seed" values from the initial seed:
;;;     SEED, (G SEED), (G^2 SEED), (G^3 SEED), ...
;;; - P tells us when to stop -- when it returns true when applied to one 
;;;   of these seed values.
;;; - F maps each seed value to the corresponding character 
;;;   in the result string. These chars are assembled into the
;;;   string in a left-to-right order.
;;; - BASE is the optional initial/leftmost portion of the constructed string;
;;;   it defaults to the empty string "".
;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns
;;;   true) to produce the final/rightmost portion of the constructed string.
;;;   It defaults to (LAMBDA (X) "").
;;;
;;; In other words, the following (simple, inefficient) definition holds:
;;; (define (string-unfold p f g seed base make-final)
;;;   (string-append base
;;;                  (let recur ((seed seed))
;;;                    (if (p seed) (make-final seed)
;;;                        (string-append (string (f seed))
;;;                                       (recur (g seed)))))))
;;; 
;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to
;;; reverse a string, copy a string, convert a list to a string, read
;;; a port into a string, and so forth. Examples:
;;; (port->string port) =
;;;   (string-unfold (compose eof-object? peek-char)
;;;                  read-char values port)
;;;
;;; (list->string lis) = (string-unfold null? car cdr lis)
;;; 
;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0)

;;; A problem with the following simple formulation is that it pushes one
;;; stack frame for every char in the result string -- an issue if you are
;;; using it to read a 100kchar string. So we don't use it -- but I include
;;; it to give a clear, straightforward description of what the function
;;; does.

;(define (string-unfold p f g seed base make-final)
;  (let ((ans (let recur ((seed seed) (i (string-length base)))
;               (if (p seed)
;                   (let* ((final (make-final seed))
;                          (ans (make-string (+ i (string-length final)))))
;                     (string-copy! ans i final)
;                     ans)
;
;                   (let* ((c (f seed))
;                          (s (recur (g seed) (+ i 1))))
;                     (string-set! s i c)
;                     s)))))
;    (string-copy! ans 0 base)
;    ans))

;;; The strategy is to allocate a series of chunks into which we stash the
;;; chars as we generate them. Chunk size goes up in powers of two starting
;;; with 40 and levelling out at 4k, i.e.
;;;     40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096...
;;; This should work pretty well for short strings, 1-line (80 char) strings,
;;; and longer ones. When done, we allocate an answer string and copy the
;;; chars over from the chunk buffers.

(define (string-unfold p f g seed . base+make-final)
;  (check-arg procedure? p string-unfold)
;  (check-arg procedure? f string-unfold)
;  (check-arg procedure? g string-unfold)
  (let-optionals* base+make-final
                  ((base       "")              ; (string? base))
		   (make-final (lambda (x) ""))) ;(procedure? make-final)))
    (let lp ((chunks '())		; Previously filled chunks
	     (nchars 0)			; Number of chars in CHUNKS
	     (chunk (make-string 40))	; Current chunk into which we write
	     (chunk-len 40)
	     (i 0)			; Number of chars written into CHUNK
	     (seed seed))
      (let lp2 ((i i) (seed seed))
	(if (not (p seed))
	    (let ((c (f seed))
		  (seed (g seed)))
	      (if (< i chunk-len)
		  (begin (string-set! chunk i c)
			 (lp2 (+ i 1) seed))

		  (let* ((nchars2 (+ chunk-len nchars))
			 (chunk-len2 (min 4096 nchars2))
			 (new-chunk (make-string chunk-len2)))
		    (string-set! new-chunk 0 c)
		    (lp (cons chunk chunks) (+ nchars chunk-len)
			new-chunk chunk-len2 1 seed))))

	    ;; We're done. Make the answer string & install the bits.
	    (let* ((final (make-final seed))
		   (flen (string-length final))
		   (base-len (string-length base))
		   (j (+ base-len nchars i))
		   (ans (make-string (+ j flen))))
	      (%string-copy! ans j final 0 flen)	; Install FINAL.
	      (let ((j (- j i)))
		(%string-copy! ans j chunk 0 i)		; Install CHUNK[0,I).
		(let lp ((j j) (chunks chunks))		; Install CHUNKS.
		  (if (pair? chunks)
		      (let* ((chunk  (car chunks))
			     (chunks (cdr chunks))
			     (chunk-len (string-length chunk))
			     (j (- j chunk-len)))
			(%string-copy! ans j chunk 0 chunk-len)
			(lp j chunks)))))
	      (%string-copy! ans 0 base 0 base-len)	; Install BASE.
	      ans))))))

(define (string-unfold-right p f g seed . base+make-final)
  (let-optionals* base+make-final
                  ((base       "");              (string? base))
		   (make-final (lambda (x) ""))); (procedure? make-final)))
    (let lp ((chunks '())		; Previously filled chunks
	     (nchars 0)			; Number of chars in CHUNKS
	     (chunk (make-string 40))	; Current chunk into which we write
	     (chunk-len 40)
	     (i 40)			; Number of chars available in CHUNK
	     (seed seed))
      (let lp2 ((i i) (seed seed))	; Fill up CHUNK from right
	(if (not (p seed))		; to left.
	    (let ((c (f seed))
		  (seed (g seed)))
	      (if (> i 0)
		  (let ((i (- i 1)))
		    (string-set! chunk i c)
		    (lp2 i seed))

		  (let* ((nchars2 (+ chunk-len nchars))
			 (chunk-len2 (min 4096 nchars2))
			 (new-chunk (make-string chunk-len2))
			 (i (- chunk-len2 1)))
		    (string-set! new-chunk i c)
		    (lp (cons chunk chunks) (+ nchars chunk-len)
			new-chunk chunk-len2 i seed))))

	    ;; We're done. Make the answer string & install the bits.
	    (let* ((final (make-final seed))
		   (flen (string-length final))
		   (base-len (string-length base))
		   (chunk-used (- chunk-len i))
		   (j (+ base-len nchars chunk-used))
		   (ans (make-string (+ j flen))))
	      (%string-copy! ans 0 final 0 flen)	; Install FINAL.
	      (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,).
	      (let lp ((j (+ flen chunk-used))		; Install CHUNKS.
		       (chunks chunks))		
		  (if (pair? chunks)
		      (let* ((chunk  (car chunks))
			     (chunks (cdr chunks))
			     (chunk-len (string-length chunk)))
			(%string-copy! ans j chunk 0 chunk-len)
			(lp (+ j chunk-len) chunks))
		      (%string-copy! ans j base 0 base-len))); Install BASE.
	      ans))))))


(define (string-for-each proc s . maybe-start+end)
;  (check-arg procedure? proc string-for-each)
  (let-string-start+end (start end) string-for-each s maybe-start+end
    (let lp ((i start))
      (if (< i end)
	  (begin (proc (string-ref s i)) 
		 (lp (+ i 1)))))))

(define (string-for-each-index proc s . maybe-start+end)
;  (check-arg procedure? proc string-for-each-index)
  (let-string-start+end (start end) string-for-each-index s maybe-start+end
    (let lp ((i start))
      (if (< i end) (begin (proc i) (lp (+ i 1)))))))

(define (string-every criteria s . maybe-start+end)
  (let-string-start+end (start end) string-every s maybe-start+end
    (cond ((char? criteria)
	   (let lp ((i start))
	     (or (>= i end)
		 (and (char=? criteria (string-ref s i))
		      (lp (+ i 1))))))

	  ((char-set? criteria)
	   (let lp ((i start))
	     (or (>= i end)
		 (and (char-set-contains? criteria (string-ref s i))
		      (lp (+ i 1))))))

	  ((procedure? criteria)		; Slightly funky loop so that
	   (or (= start end)			; final (PRED S[END-1]) call
	       (let lp ((i start))		; is a tail call.
		 (let ((c (string-ref s i))
		       (i1 (+ i 1)))
		   (if (= i1 end) (criteria c)	; Tail call.
		       (and (criteria c) (lp i1)))))))

	  (else (##sys#error 'string-every "Second param is neither char-set, char, or predicate procedure."
		       string-every criteria)))))


(define (string-any criteria s . maybe-start+end)
  (let-string-start+end (start end) string-any s maybe-start+end
    (cond ((char? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (or (char=? criteria (string-ref s i))
		      (lp (+ i 1))))))

	  ((char-set? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (or (char-set-contains? criteria (string-ref s i))
		      (lp (+ i 1))))))

	  ((procedure? criteria)		; Slightly funky loop so that
	   (and (< start end)			; final (PRED S[END-1]) call
		(let lp ((i start))		; is a tail call.
		  (let ((c (string-ref s i))
			(i1 (+ i 1)))
		    (if (= i1 end) (criteria c)	; Tail call
			(or (criteria c) (lp i1)))))))

	  (else (##sys#error 'string-any "Second param is neither char-set, char, or predicate procedure."
		       string-any criteria)))))


(define (string-tabulate proc len)
;  (check-arg procedure? proc string-tabulate)
;  (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val)))
;	     len string-tabulate)
  (##sys#check-exact len 'string-tabulate)
  (let ((s (make-string len)))
    (do ((i (- len 1) (- i 1)))
	((< i 0))
      (string-set! s i (proc i)))
    s))



;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2]
;;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Find the length of the common prefix/suffix.
;;; It is not required that the two substrings passed be of equal length.
;;; This was microcode in MIT Scheme -- a very tightly bummed primitive.
;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons,
;;; so should be as tense as possible.

(define (%string-prefix-length s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (end1 (+ start1 delta)))

    (if (and (eq? s1 s2) (= start1 start2))	; EQ fast path
	delta

	(let lp ((i start1) (j start2))		; Regular path
	  (if (or (>= i end1)
		  (not (char=? (string-ref s1 i)
			       (string-ref s2 j))))
	      (- i start1)
	      (lp (+ i 1) (+ j 1)))))))

(define (%string-suffix-length s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (start1 (- end1 delta)))

    (if (and (eq? s1 s2) (= end1 end2))		; EQ fast path
	delta

	(let lp ((i (- end1 1)) (j (- end2 1)))	; Regular path
	  (if (or (< i start1)
		  (not (char=? (string-ref s1 i)
			       (string-ref s2 j))))
	      (- (- end1 i) 1)
	      (lp (- i 1) (- j 1)))))))

(define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (end1 (+ start1 delta)))

    (if (and (eq? s1 s2) (= start1 start2))	; EQ fast path
	delta

	(let lp ((i start1) (j start2))		; Regular path
	  (if (or (>= i end1)
		  (not (char-ci=? (string-ref s1 i)
				  (string-ref s2 j))))
	      (- i start1)
	      (lp (+ i 1) (+ j 1)))))))

(define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)
  (let* ((delta (min (- end1 start1) (- end2 start2)))
	 (start1 (- end1 delta)))

    (if (and (eq? s1 s2) (= end1 end2))		; EQ fast path
	delta

	(let lp ((i (- end1 1)) (j (- end2 1)))	; Regular path
	  (if (or (< i start1)
		  (not (char-ci=? (string-ref s1 i)
				  (string-ref s2 j))))
	      (- (- end1 i) 1)
	      (lp (- i 1) (- j 1)))))))


(define (string-prefix-length s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-prefix-length s1 s2 maybe-starts+ends
    (%string-prefix-length s1 start1 end1 s2 start2 end2)))

(define (string-suffix-length s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-suffix-length s1 s2 maybe-starts+ends
    (%string-suffix-length s1 start1 end1 s2 start2 end2)))

(define (string-prefix-length-ci s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-prefix-length-ci s1 s2 maybe-starts+ends
    (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))

(define (string-suffix-length-ci s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-suffix-length-ci s1 s2 maybe-starts+ends
    (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)))


;;; string-prefix?    s1 s2 [start1 end1 start2 end2]
;;; string-suffix?    s1 s2 [start1 end1 start2 end2]
;;; string-prefix-ci? s1 s2 [start1 end1 start2 end2]
;;; string-suffix-ci? s1 s2 [start1 end1 start2 end2]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These are all simple derivatives of the previous counting funs.

(define (string-prefix? s1 s2 . maybe-starts+ends)