summaryrefslogtreecommitdiffstats
path: root/strsrch.scm
diff options
context:
space:
mode:
authorSteve Langasek <vorlon@debian.org>2005-01-10 08:53:33 +0000
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:30 -0800
commite33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e (patch)
treeabbf06041619e445f9d0b772b0d58132009d8234 /strsrch.scm
parentf559c149c83da84d0b1c285f0298c84aec564af9 (diff)
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e.tar.gz
slib-e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e.zip
Import Debian changes 3a1-4.2debian/3a1-4.2
slib (3a1-4.2) unstable; urgency=low * Non-maintainer upload. * Add guile.init.local for use within the build dir, since otherwise we have an (earlier unnoticed) circular build-dep due to a difference between scm and guile. slib (3a1-4.1) unstable; urgency=low * Non-maintainer upload. * Build-depend on guile-1.6 instead of scm, since the new version of scm is wedged in unstable (closes: #281809). slib (3a1-4) unstable; urgency=low * Also check for expected creation on slibcat. (Closes: #240096) slib (3a1-3) unstable; urgency=low * Also check for /usr/share/guile/1.6/slib before installing for guile 1.6. (Closes: #239267) slib (3a1-2) unstable; urgency=low * Add format.scm back into slib until gnucash stops using it. * Call guile-1.6 new-catalog (Closes: #238231) slib (3a1-1) unstable; urgency=low * New upstream release * Remove Info section from doc-base file (Closes: #186950) * Remove period from end of description (linda, lintian) * html gen fixed upstream (Closes: #111778) slib (2d4-2) unstable; urgency=low * Fix url for upstream source (Closes: #144981) * Fix typo in slib.texi (enquque->enqueue) (Closes: #147475) * Add build depends. slib (2d4-1) unstable; urgency=low * New upstream. slib (2d3-1) unstable; urgency=low * New upstream. * Remove texi2html call in debian/rules. Now done upstream. Add make html instead. * Changes to rules and doc-base to conform to upstream html gen * Clean up upstream makefile to make sure it cleans up after itself.
Diffstat (limited to 'strsrch.scm')
-rw-r--r--strsrch.scm164
1 files changed, 105 insertions, 59 deletions
diff --git a/strsrch.scm b/strsrch.scm
index a6ab7e1..7773e51 100644
--- a/strsrch.scm
+++ b/strsrch.scm
@@ -1,67 +1,109 @@
;;; "MISCIO" Search for string from port.
-; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu)
-; Modified 1996, 1997, 1998 by A. Jaffer (jaffer@ai.mit.edu)
+; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org)
+; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu)
+; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu)
;
; This code is in the public domain.
-;;; Return the index of the first occurence of a-char in str, or #f
-(define (strsrch:string-index str a-char)
- (let loop ((pos 0))
- (cond
- ;; whole string has been searched, in vain
- ((>= pos (string-length str)) #f)
- ((char=? a-char (string-ref str pos)) pos)
- (else (loop (+ 1 pos))))))
-
-(define (string-index-ci str a-char)
- (let loop ((pos 0))
- (cond
- ;; whole string has been searched, in vain
- ((>= pos (string-length str)) #f)
- ((char-ci=? a-char (string-ref str pos)) pos)
- (else (loop (+ 1 pos))))))
-
-(define (string-reverse-index str a-char)
- (let loop ((pos (- (string-length str) 1)))
- (cond ((< pos 0) #f)
- ((char=? (string-ref str pos) a-char) pos)
- (else (loop (- pos 1))))))
+;;;@ Return the index of the first occurence of chr in str, or #f
+(define (strsrch:string-index str chr)
+ (define len (string-length str))
+ (do ((pos 0 (+ 1 pos)))
+ ((or (>= pos len) (char=? chr (string-ref str pos)))
+ (and (< pos len) pos))))
+;@
+(define (string-index-ci str chr)
+ (define len (string-length str))
+ (do ((pos 0 (+ 1 pos)))
+ ((or (>= pos len) (char-ci=? chr (string-ref str pos)))
+ (and (< pos len) pos))))
+;@
+(define (string-reverse-index str chr)
+ (do ((pos (+ -1 (string-length str)) (+ -1 pos)))
+ ((or (negative? pos) (char=? (string-ref str pos) chr))
+ (and (not (negative? pos)) pos))))
+;@
+(define (string-reverse-index-ci str chr)
+ (do ((pos (+ -1 (string-length str)) (+ -1 pos)))
+ ((or (negative? pos) (char-ci=? (string-ref str pos) chr))
+ (and (not (negative? pos)) pos))))
+;@
+(define (substring? pat str)
+ (define patlen (string-length pat))
+ (define strlen (string-length str))
+ (cond ((zero? patlen) 0) ; trivial match
+ ((>= patlen strlen) (and (= patlen strlen) (string=? pat str) 0))
+ ;; use faster string-index to match a single-character pattern
+ ((= 1 patlen) (strsrch:string-index str (string-ref pat 0)))
+ ((or (<= strlen (+ patlen patlen (quotient char-code-limit 2)))
+ (<= patlen 4))
+ (subloop pat patlen str strlen char=?))
+ (else
+ ;; compute skip values for search pattern characters
+ ;; for all c not in pat, skip[c] = patlen + 1
+ ;; for c in pat, skip[c] is distance of rightmost occurrence
+ ;; of c from end of str
+ (let ((skip (make-vector char-code-limit (+ patlen 1))))
+ (do ((i 0 (+ i 1)))
+ ((= i patlen))
+ (vector-set! skip (char->integer (string-ref pat i))
+ (- patlen i)))
+ (subskip skip pat patlen str strlen char=?)))))
+;@
+(define (substring-ci? pat str)
+ (define patlen (string-length pat))
+ (define strlen (string-length str))
+ (cond ((zero? patlen) 0) ; trivial match
+ ((>= patlen strlen) (and (= patlen strlen) (string-ci=? pat str) 0))
+ ((= 1 patlen) (strsrch:string-index-ci str (string-ref pat 0)))
+ ((or (<= strlen (+ patlen patlen (quotient char-code-limit 2)))
+ (<= patlen 4))
+ (subloop pat patlen str strlen char-ci=?))
+ (else
+ (let ((skip (make-vector char-code-limit (+ patlen 1))))
+ (do ((i 0 (+ i 1)))
+ ((= i patlen))
+ (let ((c (string-ref pat i))
+ (d (- patlen i)))
+ ;; use same skip value for both upper- and lowercase characters
+ (vector-set! skip (char->integer (char-upcase c)) d)
+ (vector-set! skip (char->integer (char-downcase c)) d)))
+ (subskip skip pat patlen str strlen char-ci=?)))))
-(define (string-reverse-index-ci str a-char)
- (let loop ((pos (- (string-length str) 1)))
- (cond ((< pos 0) #f)
- ((char-ci=? (string-ref str pos) a-char) pos)
- (else (loop (- pos 1))))))
+(define (subskip skip pat patlen str strlen char=)
+ (do ((k patlen (if (< k strlen)
+ (+ k (vector-ref skip (char->integer (string-ref str k))))
+ (+ strlen 1))))
+ ((or (> k strlen)
+ (do ((i 0 (+ i 1))
+ (j (- k patlen) (+ j 1)))
+ ((or (= i patlen)
+ (not (char= (string-ref pat i) (string-ref str j))))
+ (= i patlen))))
+ (and (<= k strlen) (- k patlen)))))
-(define (miscio:substring? pattern str char=?)
- (let* ((pat-len (string-length pattern))
- (search-span (- (string-length str) pat-len))
- (c1 (if (zero? pat-len) #f (string-ref pattern 0)))
- (c2 (if (<= pat-len 1) #f (string-ref pattern 1))))
+;;; Assumes that PATLEN > 1
+(define (subloop pat patlen str strlen char=)
+ (define span (- strlen patlen))
+ (define c1 (string-ref pat 0))
+ (define c2 (string-ref pat 1))
+ (let outer ((pos 0))
(cond
- ((not c1) 0) ; empty pattern, matches upfront
- ((not c2) (strsrch:string-index str c1)) ; one-char pattern
- (else ; matching pattern of > two chars
- (let outer ((pos 0))
- (cond
- ((> pos search-span) #f) ; nothing was found thru the whole str
- ((not (char=? c1 (string-ref str pos)))
- (outer (+ 1 pos))) ; keep looking for the right beginning
- ((not (char=? c2 (string-ref str (+ 1 pos))))
- (outer (+ 1 pos))) ; could've done pos+2 if c1 == c2....
- (else ; two char matched: high probability
+ ((> pos span) #f) ; nothing was found thru the whole str
+ ((not (char= c1 (string-ref str pos)))
+ (outer (+ 1 pos))) ; keep looking for the right beginning
+ ((not (char= c2 (string-ref str (+ 1 pos))))
+ (outer (+ 1 pos))) ; could've done pos+2 if c1 == c2....
+ (else ; two char matched: high probability
; the rest will match too
- (let inner ((i-pat 2) (i-str (+ 2 pos)))
- (if (>= i-pat pat-len) pos ; the whole pattern matched
- (if (char=? (string-ref pattern i-pat)
- (string-ref str i-str))
- (inner (+ 1 i-pat) (+ 1 i-str))
- ;; mismatch after partial match
- (outer (+ 1 pos))))))))))))
-
-(define (substring? pattern str) (miscio:substring? pattern str char=?))
-(define (substring-ci? pattern str) (miscio:substring? pattern str char-ci=?))
-
+ (let inner ((pdx 2) (sdx (+ 2 pos)))
+ (if (>= pdx patlen) pos ; the whole pat matched
+ (if (char= (string-ref pat pdx)
+ (string-ref str sdx))
+ (inner (+ 1 pdx) (+ 1 sdx))
+ ;; mismatch after partial match
+ (outer (+ 1 pos)))))))))
+;@
(define (find-string-from-port? str <input-port> . max-no-char)
(set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
(letrec
@@ -94,7 +136,7 @@
(match-other-chars
(lambda (pos-to-match)
(if (>= pos-to-match (string-length str))
- no-chars-read ; the entire string has matched
+ no-chars-read ; the entire string has matched
(let ((c (my-peek-char)))
(and c
(if (not (char=? c (string-ref str pos-to-match)))
@@ -124,7 +166,7 @@
(backtrack (+ 1 i) matched-substr-len))))))))
)
(match-1st-char)))
-
+;@
(define (string-subst text old new . rest)
(define sub
(lambda (text)
@@ -143,4 +185,8 @@
text
(apply string-subst text rest))))
(sub text))
-
+;@
+(define (count-newlines str)
+ (do ((idx (+ -1 (string-length str)) (+ -1 idx))
+ (cnt 0 (+ (if (eqv? #\newline (string-ref str idx)) 1 0) cnt)))
+ ((<= idx 0) cnt)))