srfi-13.scm

Scheme跨平台编译器

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

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

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

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


;;; Here are the internal routines that do the real work.

(define (%string-prefix? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= (%string-prefix-length s1 start1 end1
				   s2 start2 end2)
	    len1))))

(define (%string-suffix? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= len1 (%string-suffix-length s1 start1 end1
					s2 start2 end2)))))

(define (%string-prefix-ci? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= len1 (%string-prefix-length-ci s1 start1 end1
					   s2 start2 end2)))))

(define (%string-suffix-ci? s1 start1 end1 s2 start2 end2)
  (let ((len1 (- end1 start1)))
    (and (<= len1 (- end2 start2))	; Quick check
	 (= len1 (%string-suffix-length-ci s1 start1 end1
					   s2 start2 end2)))))


;;; string-compare    s1 s2 proc< proc= proc> [start1 end1 start2 end2]
;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Primitive string-comparison functions.
;;; Continuation order is different from MIT Scheme.
;;; Continuations are applied to s1's mismatch index;
;;; in the case of equality, this is END1.

(define (%string-compare s1 start1 end1 s2 start2 end2
			   proc< proc= proc>)
  (let ((size1 (- end1 start1))
	(size2 (- end2 start2)))
    (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2)))
      (if (= match size1)
	  ((if (= match size2) proc= proc<) end1)
	  ((if (= match size2)
	       proc>
	       (if (char<? (string-ref s1 (+ start1 match))
			   (string-ref s2 (+ start2 match)))
		   proc< proc>))
	   (+ match start1))))))

(define (%string-compare-ci s1 start1 end1 s2 start2 end2
			      proc< proc= proc>)
  (let ((size1 (- end1 start1))
	(size2 (- end2 start2)))
    (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
      (if (= match size1)
	  ((if (= match size2) proc= proc<) end1)
	  ((if (= match size2) proc>
	       (if (char-ci<? (string-ref s1 (+ start1 match))
			      (string-ref s2 (+ start2 match)))
		   proc< proc>))
	   (+ start1 match))))))

(define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends)
;  (check-arg procedure? proc< string-compare)
;  (check-arg procedure? proc= string-compare)
;  (check-arg procedure? proc> string-compare)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-compare s1 s2 maybe-starts+ends
    (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>)))

(define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends)
;  (check-arg procedure? proc< string-compare-ci)
;  (check-arg procedure? proc= string-compare-ci)
;  (check-arg procedure? proc> string-compare-ci)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-compare-ci s1 s2 maybe-starts+ends
    (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>)))



;;; string=          string<>		string-ci=          string-ci<>
;;; string<          string>		string-ci<          string-ci>
;;; string<=         string>=		string-ci<=         string-ci>=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simple definitions in terms of the previous comparison funs.
;;; I sure hope the %STRING-COMPARE calls get integrated.

(define (string= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string= s1 s2 maybe-starts+ends
    (and (= (- end1 start1) (- end2 start2))			; Quick filter
	 (or (and (eq? s1 s2) (= start1 start2))		; Fast path
	     (%string-compare s1 start1 end1 s2 start2 end2	; Real test
			      (lambda (i) #f)
			      values
			      (lambda (i) #f))))))

(define (string<> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string<> s1 s2 maybe-starts+ends
    (or (not (= (- end1 start1) (- end2 start2)))		; Fast path
	(and (not (and (eq? s1 s2) (= start1 start2)))		; Quick filter
	     (%string-compare s1 start1 end1 s2 start2 end2	; Real test
			      values
			      (lambda (i) #f)
			      values)))))

(define (string< s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string< s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(< end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 values
			 (lambda (i) #f)
			 (lambda (i) #f)))))

(define (string> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string> s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(> end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 (lambda (i) #f)
			 (lambda (i) #f)
			 values))))

(define (string<= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string<= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(<= end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 values
			 values
			 (lambda (i) #f)))))

(define (string>= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string>= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(>= end1 end2)

	(%string-compare s1 start1 end1 s2 start2 end2 		; Real test
			 (lambda (i) #f)
			 values
			 values))))

(define (string-ci= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-ci= s1 s2 maybe-starts+ends
    (and (= (- end1 start1) (- end2 start2))			; Quick filter
	 (or (and (eq? s1 s2) (= start1 start2))		; Fast path
	     (%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
				 (lambda (i) #f)
				 values
				 (lambda (i) #f))))))

(define (string-ci<> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-ci<> s1 s2 maybe-starts+ends
    (or (not (= (- end1 start1) (- end2 start2)))		; Fast path
	(and (not (and (eq? s1 s2) (= start1 start2)))		; Quick filter
	     (%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
				 values
				 (lambda (i) #f)
				 values)))))

(define (string-ci< s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-ci< s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(< end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    values
			    (lambda (i) #f)
			    (lambda (i) #f)))))

(define (string-ci> s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-ci> s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(> end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    (lambda (i) #f)
			    (lambda (i) #f)
			    values))))

(define (string-ci<= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-ci<= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(<= end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    values
			    values
			    (lambda (i) #f)))))

(define (string-ci>= s1 s2 . maybe-starts+ends)
  (let-string-start+end2 (start1 end1 start2 end2) 
			 string-ci>= s1 s2 maybe-starts+ends
    (if (and (eq? s1 s2) (= start1 start2))			; Fast path
	(>= end1 end2)

	(%string-compare-ci s1 start1 end1 s2 start2 end2	; Real test
			    (lambda (i) #f)
			    values
			    values))))


;;; Hash
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND.
;;; If you keep BOUND small enough, the intermediate calculations will 
;;; always be fixnums. How small is dependent on the underlying Scheme system; 
;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
;;; Schemes that give you at least 29 signed bits for fixnums. The core 
;;; calculation that you don't want to overflow is, worst case,
;;;     (+ 65535 (* 37 (- bound 1)))
;;; where 65535 is the max character code. Choose the default BOUND to be the
;;; biggest power of two that won't cause this expression to fixnum overflow, 
;;; and everything will be copacetic.

(define (%string-hash s char->int bound start end)
  (let ((iref (lambda (s i) (char->int (string-ref s i))))
	;; Compute a 111...1 mask that will cover BOUND-1:
	(mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
		(if (>= i bound) (- i 1) (lp (+ i i))))))
    (let lp ((i start) (ans 0))
      (if (>= i end) (modulo ans bound)
	  (lp (+ i 1) (fxand mask (+ (* 37 ans) (iref s i))))))))

(define (string-hash s . maybe-bound+start+end)
  (let-optionals* maybe-bound+start+end ((bound 4194304); (and (integer? bound)
							;     (exact? bound)
							;     (<= 0 bound)))
					 rest)
    (if (zero? bound) (set! bound 4194304))
    (##sys#check-exact bound 'string-hash)		
    (let-string-start+end (start end) string-hash s rest
      (%string-hash s char->integer bound start end))))

(define (string-hash-ci s . maybe-bound+start+end)
  (let-optionals* maybe-bound+start+end ((bound 4194304) ;(and (integer? bound)
							 ;    (exact? bound)
							 ;    (<= 0 bound)))
					 rest)
    (if (zero? bound) (set! bound 4194304))
    (##sys#check-exact bound 'string-hash-ci)
    (let-string-start+end (start end) string-hash-ci s rest
      (%string-hash s (lambda (c) (char->integer (char-downcase c)))
		    bound start end))))

;;; Case hacking
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-upcase  s [start end]
;;; string-upcase! s [start end]
;;; string-downcase  s [start end]
;;; string-downcase! s [start end]
;;;
;;; string-titlecase  s [start end]
;;; string-titlecase! s [start end]
;;;   Capitalize every contiguous alpha sequence: capitalise
;;;   first char, lowercase rest.

(define (string-upcase  s . maybe-start+end)
  (let-string-start+end (start end) string-upcase s maybe-start+end
    (%string-map char-upcase s start end)))

(define (string-upcase! s . maybe-start+end)
  (let-string-start+end (start end) string-upcase! s maybe-start+end
    (%string-map! char-upcase s start end)))

(define (string-downcase  s . maybe-start+end)
  (let-string-start+end (start end) string-downcase s maybe-start+end
    (%string-map char-downcase s start end)))

(define (string-downcase! s . maybe-start+end)
  (let-string-start+end (start end) string-downcase! s maybe-start+end
    (%string-map! char-downcase s start end)))

(define (%string-titlecase! s start end)
  (let lp ((i start))
    (cond ((string-index s char-cased? i end) =>
           (lambda (i)
	     (string-set! s i (char-titlecase (string-ref s i)))
	     (let ((i1 (+ i 1)))
	       (cond ((string-skip s char-cased? i1 end) =>
		      (lambda (j)
			(string-downcase! s i1 j)
			(lp (+ j 1))))
		     (else (string-downcase! s i1 end)))))))))

(define (string-titlecase! s . maybe-start+end)
  (let-string-start+end (start end) string-titlecase! s maybe-start+end
    (%string-titlecase! s start end)))

(define (string-titlecase s . maybe-start+end)
  (let-string-start+end (start end) string-titlecase! s maybe-start+end
    (let ((ans (##sys#substring s start end)))
      (%string-titlecase! ans 0 (- end start))
      ans)))


;;; Cutting & pasting strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string-take string nchars
;;; string-drop string nchars
;;;
;;; string-take-right string nchars
;;; string-drop-right string nchars
;;;
;;; string-pad string k [char start end] 
;;; string-pad-right string k [char start end] 
;;; 
;;; string-trim       string [char/char-set/pred start end] 
;;; string-trim-right string [char/char-set/pred start end] 
;;; string-trim-both  string [char/char-set/pred start end] 
;;;
;;; These trimmers invert the char-set meaning from MIT Scheme -- you
;;; say what you want to trim.