srfi-13.scm

来自「Scheme跨平台编译器」· SCM 代码 · 共 1,745 行 · 第 1/5 页

(define (string-take s n)
;  (check-arg string? s string-take)
;  (check-arg (lambda (val) (and (integer? n) (exact? n)
;				(<= 0 n (string-length s))))
;	     n string-take)
  (##sys#check-string s 'string-take)
  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take)
  (%substring/shared s 0 n))

(define (string-take-right s n)
;  (check-arg string? s string-take-right)
  (##sys#check-string s 'string-take-right)
  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take-right)
  (let ((len (##sys#size s)))
;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
;	       n string-take-right)
    (%substring/shared s (- len n) len)))

(define (string-drop s n)
;  (check-arg string? s string-drop)
  (##sys#check-string s 'string-drop)
  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop)
  (let ((len (##sys#size s)))
;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
;	       n string-drop)
    (%substring/shared s n len)))

(define (string-drop-right s n)
;  (check-arg string? s string-drop-right)
  (##sys#check-string s 'string-drop-right)
  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop-right)
  (let ((len (##sys#size s)))
;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
;	       n string-drop-right)
    (%substring/shared s 0 (- len n))))


(define (string-trim s . criteria+start+end)
  (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
    (let-string-start+end (start end) string-trim s rest
      (cond ((string-skip s criteria start end) =>
	     (lambda (i) (%substring/shared s i end)))
	    (else "")))))

(define (string-trim-right s . criteria+start+end)
  (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
    (let-string-start+end (start end) string-trim-right s rest
      (cond ((string-skip-right s criteria start end) =>
	     (lambda (i) (%substring/shared s 0 (+ 1 i))))
	    (else "")))))

(define (string-trim-both s . criteria+start+end)
  (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
    (let-string-start+end (start end) string-trim-both s rest
      (cond ((string-skip s criteria start end) =>
	     (lambda (i)
	       (%substring/shared s i (+ 1 (string-skip-right s criteria i end)))))
	    (else "")))))


(define (string-pad-right s n . char+start+end)
  (##sys#check-exact n 'string-pad-right)
  (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest)
    (let-string-start+end (start end) string-pad-right s rest
      (let ((len (- end start)))
	(if (<= n len)
	    (%substring/shared s start (+ start n))
	    (let ((ans (make-string n char)))
	      (%string-copy! ans 0 s start end)
	      ans))))))

(define (string-pad s n . char+start+end)
  (##sys#check-exact n 'string-pad)
  (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest)
    (let-string-start+end (start end) string-pad s rest
      (let ((len (- end start)))
	(if (<= n len)
	    (%substring/shared s (- end n) end)
	    (let ((ans (make-string n char)))
	      (%string-copy! ans (- n len) s start end)
	      ans))))))



;;; Filtering strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-delete char/char-set/pred string [start end]
;;; string-filter char/char-set/pred string [start end]
;;;
;;; If the criteria is a char or char-set, we scan the string twice with
;;;   string-fold -- once to determine the length of the result string, 
;;;   and once to do the filtered copy.
;;; If the criteria is a predicate, we don't do this double-scan strategy, 
;;;   because the predicate might have side-effects or be very expensive to
;;;   compute. So we preallocate a temp buffer pessimistically, and only do
;;;   one scan over S. This is likely to be faster and more space-efficient
;;;   than consing a list.

(define (string-delete criteria s . maybe-start+end)
  (let-string-start+end (start end) string-delete s maybe-start+end
    (if (procedure? criteria)
	(let* ((slen (- end start))
	       (temp (make-string slen))
	       (ans-len (string-fold (lambda (c i)
				       (if (criteria c) i
					   (begin (string-set! temp i c)
						  (+ i 1))))
				     0 s start end)))
	  (if (= ans-len slen) temp (##sys#substring temp 0 ans-len)))

	(let* ((cset (cond ((char-set? criteria) criteria)
			   ((char? criteria) (char-set criteria))
			   (else (##sys#error 'string-delete "string-delete criteria not predicate, char or char-set" criteria))))
	       (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
						   i
						   (+ i 1)))
				 0 s start end))
	       (ans (make-string len)))
	  (string-fold (lambda (c i) (if (char-set-contains? cset c)
					 i
					 (begin (string-set! ans i c)
						(+ i 1))))
		       0 s start end)
	  ans))))

(define (string-filter criteria s . maybe-start+end)
  (let-string-start+end (start end) string-filter s maybe-start+end
    (if (procedure? criteria)
	(let* ((slen (- end start))
	       (temp (make-string slen))
	       (ans-len (string-fold (lambda (c i)
				       (if (criteria c)
					   (begin (string-set! temp i c)
						  (+ i 1))
					   i))
				     0 s start end)))
	  (if (= ans-len slen) temp (##sys#substring temp 0 ans-len)))

	(let* ((cset (cond ((char-set? criteria) criteria)
			   ((char? criteria) (char-set criteria))
			   (else (##sys#error 'string-filter "string-delete criteria not predicate, char or char-set" criteria))))

	       (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
						   (+ i 1)
						   i))
				 0 s start end))
	       (ans (make-string len)))
	  (string-fold (lambda (c i) (if (char-set-contains? cset c)
					 (begin (string-set! ans i c)
						(+ i 1))
					 i))
		       0 s start end)
	  ans))))


;;; String search
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-index       string char/char-set/pred [start end]
;;; string-index-right string char/char-set/pred [start end]
;;; string-skip        string char/char-set/pred [start end]
;;; string-skip-right  string char/char-set/pred [start end]
;;; string-count       char/char-set/pred string [start end]
;;;     There's a lot of replicated code here for efficiency.
;;;     For example, the char/char-set/pred discrimination has
;;;     been lifted above the inner loop of each proc.

(define (string-index str criteria . maybe-start+end)
  (let-string-start+end (start end) string-index str maybe-start+end
    (cond ((char? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char=? criteria (string-ref str i)) i
		      (lp (+ i 1))))))
	  ((char-set? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char-set-contains? criteria (string-ref str i)) i
		      (lp (+ i 1))))))
	  ((procedure? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (if (criteria (string-ref str i)) i
		      (lp (+ i 1))))))
	  (else (##sys#error 'string-index "Second param is neither char-set, char, or predicate procedure."
		       string-index criteria)))))

(define (string-index-right str criteria . maybe-start+end)
  (let-string-start+end (start end) string-index-right str maybe-start+end
    (cond ((char? criteria)
	   (let lp ((i (- end 1)))
	     (and (>= i 0)
		  (if (char=? criteria (string-ref str i)) i
		      (lp (- i 1))))))
	  ((char-set? criteria)
	   (let lp ((i (- end 1)))
	     (and (>= i 0)
		  (if (char-set-contains? criteria (string-ref str i)) i
		      (lp (- i 1))))))
	  ((procedure? criteria)
	   (let lp ((i (- end 1)))
	     (and (>= i 0)
		  (if (criteria (string-ref str i)) i
		      (lp (- i 1))))))
	  (else (##sys#error 'string-index-right "Second param is neither char-set, char, or predicate procedure."
		       string-index-right criteria)))))

(define (string-skip str criteria . maybe-start+end)
  (let-string-start+end (start end) string-skip str maybe-start+end
    (cond ((char? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char=? criteria (string-ref str i))
		      (lp (+ i 1))
		      i))))
	  ((char-set? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (if (char-set-contains? criteria (string-ref str i))
		      (lp (+ i 1))
		      i))))
	  ((procedure? criteria)
	   (let lp ((i start))
	     (and (< i end)
		  (if (criteria (string-ref str i)) (lp (+ i 1))
		      i))))
	  (else (##sys#error 'string-skip "Second param is neither char-set, char, or predicate procedure."
		       string-skip criteria)))))

(define (string-skip-right str criteria . maybe-start+end)
  (let-string-start+end (start end) string-skip-right str maybe-start+end
    (cond ((char? criteria)
	   (let lp ((i (- end 1)))
	     (and (>= i 0)
		  (if (char=? criteria (string-ref str i))
		      (lp (- i 1))
		      i))))
	  ((char-set? criteria)
	   (let lp ((i (- end 1)))
	     (and (>= i 0)
		  (if (char-set-contains? criteria (string-ref str i))
		      (lp (- i 1))
		      i))))
	  ((procedure? criteria)
	   (let lp ((i (- end 1)))
	     (and (>= i 0)
		  (if (criteria (string-ref str i)) (lp (- i 1))
		      i))))
	  (else (##sys#error 'string-skip-right "CRITERIA param is neither char-set or char."
		       string-skip-right criteria)))))


; [felix] Boooh! original code had "s" and "criteria" in the wrong order:

(define (string-count s criteria . maybe-start+end)
  (let-string-start+end (start end) string-count s maybe-start+end
    (cond ((char? criteria)
	   (do ((i start (+ i 1))
		(count 0 (if (char=? criteria (string-ref s i))
			     (+ count 1)
			     count)))
	       ((>= i end) count)))

	  ((char-set? criteria)
	   (do ((i start (+ i 1))
		(count 0 (if (char-set-contains? criteria (string-ref s i))
			     (+ count 1)
			     count)))
	       ((>= i end) count)))

	  ((procedure? criteria)
	   (do ((i start (+ i 1))
		(count 0 (if (criteria (string-ref s i)) (+ count 1) count)))
	       ((>= i end) count)))

	  (else (##sys#error 'string-count "CRITERIA param is neither char-set or char."
		       string-count criteria)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-fill! string char [start end]
;;; 
;;; string-copy! to tstart from [fstart fend]
;;; 	Guaranteed to work, even if s1 eq s2.

(define (string-fill! s char . maybe-start+end)
;  (check-arg char? char string-fill!)
  (let-string-start+end (start end) string-fill! s maybe-start+end
    (do ((i (- end 1) (- i 1)))
	((< i start))
      (string-set! s i char))))

(define (string-copy! to tstart from . maybe-fstart+fend)
  (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend
;    (check-arg integer? tstart string-copy!)
    (##sys#check-exact tstart 'string-copy!)			
    (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart)))
    (%string-copy! to tstart from fstart fend)))

;;; Library-internal routine
(define (%string-copy! to tstart from fstart fend)
  (##core#inline "C_substring_copy" from to fstart fend tstart))


;;; Returns starting-position in STRING or #f if not true.
;;; This implementation is slow & simple. It is useful as a "spec" or for
;;; comparison testing with fancier implementations.
;;; See below for fast KMP version.

(define (string-contains string substring . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
                         string-contains string substring maybe-starts+ends
    (let* ((len (fx- end2 start2))
	   (i-bound (fx- end1 len)))
      (let lp ((i start1))
	(and (fx<= i i-bound)
	     (if (string= string substring i (fx+ i len) start2 end2)
		 i
		 (lp (fx+ i 1))))))))

(define (string-contains-ci string substring . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
                         string-contains string substring maybe-starts+ends
    (let* ((len (fx- end2 start2))
	   (i-bound (fx- end1 len)))
      (let lp ((i start1))
	(and (fx<= i i-bound)
	     (if (string-ci= string substring i (fx+ i len) start2 end2)
		 i
		 (lp (fx+ i 1))))))))


;;; Searching for an occurrence of a substring
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; this is broken. Thanks, Olin! ;-)


;;; Knuth-Morris-Pratt string searching
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; See
;;;     "Fast pattern matching in strings"
;;;     SIAM J. Computing 6(2):323-350 1977
;;;     D. E. Knuth, J. H. Morris and V. R. Pratt
;;; also described in
;;;     "Pattern matching in strings"
;;;     Alfred V. Aho
;;;     Formal Language Theory - Perspectives and Open Problems
;;;     Ronald V. Brook (editor)