64 lines
1.7 KiB
Scheme
64 lines
1.7 KiB
Scheme
|
;;; Random string-hacking procs -*- Scheme -*-
|
||
|
|
;;; Copyright (c) 1995 by Olin Shivers.
|
||
|
|
|
||
|
|
(define (string-map f s)
|
||
|
|
(let* ((slen (string-length s))
|
||
|
|
(ns (make-string slen)))
|
||
|
|
(do ((i (- slen 1) (- i 1)))
|
||
|
|
((< i 0) ns)
|
||
|
|
(string-set! ns i (f (string-ref s i))))))
|
||
|
|
|
||
|
|
(define (downcase-string s)
|
||
|
|
(string-map char-downcase s))
|
||
|
|
|
||
|
|
(define (upcase-string s)
|
||
|
|
(string-map char-upcase s))
|
||
|
|
|
||
|
|
|
||
|
|
(define (char-set-index str cset . maybe-start)
|
||
|
|
(let-optionals maybe-start ((start 0))
|
||
|
|
(let ((len (string-length str)))
|
||
|
|
(do ((i start (+ 1 i)))
|
||
|
|
((or (>= i len)
|
||
|
|
(char-set-contains? cset (string-ref str i)))
|
||
|
|
(and (< i len) i))))))
|
||
|
|
|
||
|
|
(define (char-set-rindex str cset . maybe-start)
|
||
|
|
(let ((len (string-length str)))
|
||
|
|
(let-optionals maybe-start ((start len))
|
||
|
|
(do ((i (- start 1) (- i 1)))
|
||
|
|
((or (< i 0)
|
||
|
|
(char-set-contains? cset (string-ref str i)))
|
||
|
|
(and (>= i 0) i))))))
|
||
|
|
|
||
|
|
(define (string-reduce nil cons s)
|
||
|
|
(let ((slen (string-length s)))
|
||
|
|
(do ((ans nil (cons (string-ref s i) ans))
|
||
|
|
(i 0 (+ i 1)))
|
||
|
|
((= i slen) ans))))
|
||
|
|
|
||
|
|
(define (string-prefix? prefix string)
|
||
|
|
(let ((plen (string-length prefix))
|
||
|
|
(slen (string-length string)))
|
||
|
|
(and (<= plen slen)
|
||
|
|
(let lp ((i 0))
|
||
|
|
(or (= i plen)
|
||
|
|
(and (char=? (string-ref prefix i)
|
||
|
|
(string-ref string i))
|
||
|
|
(lp (+ i 1))))))))
|
||
|
|
|
||
|
|
(define (string-suffix? suffix string)
|
||
|
|
(let ((slen (string-length suffix))
|
||
|
|
(len (string-length string)))
|
||
|
|
(and (<= slen len)
|
||
|
|
(let lp ((i (- slen 1))
|
||
|
|
(j (- len 1)))
|
||
|
|
(or (< i 0)
|
||
|
|
(and (char=? (string-ref suffix i)
|
||
|
|
(string-ref string j))
|
||
|
|
(lp (- i 1) (- j 1))))))))
|
||
|
|
|
||
|
|
(define skip-whitespace
|
||
|
|
(let ((non-whitespace (char-set-invert char-set:whitespace)))
|
||
|
|
(lambda (s) (char-set-index s non-whitespace))))
|