From fcb91fb16bb2e30f86a82b220d46549d3400214d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Dec 2005 02:29:19 +0000 Subject: [PATCH] restored old version because parens weren't balanced svn: r1451 --- collects/srfi/13/string.ss | 63 ++++++++++++++++++++++++++++---------- 1 file changed, 47 insertions(+), 16 deletions(-) diff --git a/collects/srfi/13/string.ss b/collects/srfi/13/string.ss index 81fc5b06e7..030c7ad6cd 100644 --- a/collects/srfi/13/string.ss +++ b/collects/srfi/13/string.ss @@ -1,8 +1,11 @@ ;;; ;;; ---- SRFI 13 port to PLT Scheme -;;; revised by Chongkai Zhu, based on the orgianl port +;;; Time-stamp: <2004-02-12 20:31:13 solsona> ;;; -;;; Here is the copyright notice, and licence from the original source: +;;; Usually, I would add a copyright notice, and the announce that +;;; this code is under the LGPL licence. Nevertheless, I only did the +;;; port to PLT Scheme, and here is the copyright notice, and licence +;;; from the original source: ;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology. ;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved. @@ -89,6 +92,8 @@ (lib "etc.ss");; for opt-lambda (instead of let-optionals*) ) (provide + ;; Provide char-sets: + (all-from (lib "char-set.ss" "srfi" "14")) ;; String procedures: string-map string-map! string-fold string-unfold @@ -100,7 +105,7 @@ string= string< string> string<= string>= string<> string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> s:string-downcase s:string-upcase s:string-titlecase - string-downcase! string-upcase! string-titlecase! + string-downcase! string-upcase! string-titlecase! string-take string-take-right string-drop string-drop-right string-pad string-pad-right @@ -899,28 +904,54 @@ ;; Hash + ;; + ;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in + ;; to keep the intermediate values small. (We do the calculation with just + ;; enough bits to represent BOUND, masking off high bits at each step in + ;; calculation. If this screws up any important properties of the hash + ;; function I'd like to hear about it. -Olin) + ;; + ;; 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) (bitwise-and mask (+ (* 37 ans) (iref s i)))))))) (define string-hash - (opt-lambda (s (bound 0) . rest) + (opt-lambda (s (bound 4194304) (rest '())) (check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) bound 'string-hash) - (if (zero? bound) - (equal-hash-code (apply substring/shared s rest)) - (modulo (equal-hash-code (apply substring/shared s rest)) bound)))) + (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default. + (let-string-start+end (start end) 'string-hash s rest + (%string-hash s char->integer bound start end))))) (define string-hash-ci - (opt-lambda (s (bound 0) . rest) + (opt-lambda (s (bound 4194304) (rest '())) (check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) bound 'string-hash-ci) - (if (zero? bound) - (equal-hash-code (string-downcase (apply substring/shared s rest))) - (modulo (equal-hash-code (string-downcase (apply substring/shared s rest)) bound))))) + (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default. + (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 ;; @@ -1024,21 +1055,21 @@ (define string-trim - (opt-lambda (s (criterion char-set:whitespace) . rest) + (opt-lambda (s (criterion char-set:whitespace) (rest '())) (let-string-start+end (start end) 'string-trim s rest (cond ((string-skip s criterion start end) => (lambda (i) (%substring/shared s i end))) (else ""))))) (define string-trim-right - (opt-lambda (s (criterion char-set:whitespace) . rest) + (opt-lambda (s (criterion char-set:whitespace) (rest '())) (let-string-start+end (start end) 'string-trim-right s rest (cond ((string-skip-right s criterion start end) => (lambda (i) (%substring/shared s 0 (+ 1 i)))) (else ""))))) (define string-trim-both - (opt-lambda (s (criterion char-set:whitespace) . rest)) + (opt-lambda (s (criterion char-set:whitespace) (rest '())) (let-string-start+end (start end) 'string-trim-both s rest (cond ((string-skip s criterion start end) => (lambda (i) @@ -1046,7 +1077,7 @@ (else ""))))) (define string-pad-right - (opt-lambda (s n (char #\space) . rest)) + (opt-lambda (s n (char #\space) (rest '())) (check-arg char? char 'string-pad-right) (let-string-start+end (start end) 'string-pad-right s rest (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) @@ -1059,7 +1090,7 @@ ans)))))) (define string-pad - (opt-lambda (s n (char #\space) . rest)) + (opt-lambda (s n (char #\space) (rest '())) (check-arg char? char 'string-pad) (let-string-start+end (start end) 'string-pad s rest (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n)))