suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

restored old version because parens weren't balanced

Browse Source 
svn: r1451
This commit is contained in:
Matthew Flatt 2005-12-01 02:29:19 +00:00
parent 85734c4cdb
commit fcb91fb16b
1 changed files with 47 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/srfi/13/string.ss
View File

@ -1,8 +1,11 @@
;;;
;;; <string.ss> ---- 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)))