diff --git a/lib/chibi/strings.scm b/lib/chibi/strings.scm new file mode 100644 index 00000000..b157ea3f --- /dev/null +++ b/lib/chibi/strings.scm @@ -0,0 +1,143 @@ +;; strings.scm -- cursor-oriented string library +;; Copyright (c) 2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (string-null? str) + (equal? str "")) + +;; TODO: support character sets +(define (make-char-predicate x) + (cond ((procedure? x) x) + ((char? x) (lambda (ch) (eq? ch x))) + (else (error "invalid character predicate" x)))) + +(define (complement pred) (lambda (x) (not (pred x)))) + +(define (string-every x str) + (let ((pred (make-char-predicate x)) + (end (string-cursor-end str))) + (let lp ((i (string-cursor-start str))) + (if (string-cursor>=? i end) + #t + (and (pred (string-cursor-ref str i)) + (lp (string-cursor-next str i))))))) + +(define (string-any x str) + (not (string-every (complement (make-char-predicate x)) str))) + +(define (string-index str x . o) + (let ((pred (make-char-predicate x)) + (end (string-cursor-end str))) + (let lp ((i (if (pair? o) (car o) (string-cursor-start str)))) + (cond ((string-cursor>=? i end) #f) + ((pred (string-ref str i)) i) + (else (lp (string-cursor-next str i))))))) + +(define (string-index-right str x . o) + (let ((pred (make-char-predicate x)) + (end (string-cursor-start str))) + (let lp ((i (if (pair? o) + (car o) + (string-cursor-prev str (string-cursor-end str))))) + (cond ((string-cursor=? i end1) + (string-cursor>=? j end2) + (not (eq? (string-ref prefix i) (string-ref str j)))) + j + (lp (string-cursor-next prefix i) (string-cursor-next str j)))))) + +(define (string-mismatch-right suffix str) + (let ((end1 (string-cursor-start suffix)) + (end2 (string-cursor-start str))) + (let lp ((i (string-cursor-prev suffix (string-cursor-end suffix))) + (j (string-cursor-prev str (string-cursor-end str)))) + (if (or (string-cursor=? i end) + acc + (lp (string-cursor-next str i) + (kons (string-cursor-ref str i) acc)))))) + +(define (string-fold-right kons knil str) + (let ((end (string-cursor-end str))) + (let lp ((i (string-cursor-start str))) + (if (string-cursor>=? i end) + knil + (kons (string-cursor-ref str i) (lp (string-cursor-next str i))))))) + +(define (string-count str x) + (let ((pred (make-char-predicate x))) + (string-fold (lambda (ch count) (if (pred ch) (+ count 1) count)) 0 str))) + +(define (string-for-each proc str) + (let ((end (string-cursor-end str))) + (let lp ((i (string-cursor-start str))) + (cond ((string-cursor? string-cursor>=? + string-cursor=? string-null? string-every string-any + string-join string-split string-count + string-trim string-trim-left string-trim-right + string-mismatch string-mismatch-right + string-prefix? string-suffix? + string-index string-index-right string-skip string-skip-right + string-fold string-fold-right string-map string-for-each + string-contains make-string-searcher) + (import (scheme) (chibi ast)) + (include "strings.scm")) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index d751cd71..d1128bc6 100644 --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -2,6 +2,7 @@ (define-library (scheme base) (import (except (scheme) equal?) (rename (chibi equiv) (equiv? equal?)) + (only (chibi strings) string-map string-for-each) (chibi io) (rename (only (chibi ast) exception? exception-message exception-irritants) diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm index d366b0ca..aebe40b4 100644 --- a/lib/scheme/extras.scm +++ b/lib/scheme/extras.scm @@ -104,16 +104,6 @@ (define (string->vector vec) (list->vector (string->list vec))) -(define (string-map proc . los) - (list->string (apply map proc (map string->list los)))) - -(define (string-for-each proc str . los) - (if (null? los) - (let ((len (string-length str))) - (let lp ((i 0)) - (if (< i len) (begin (proc (string-ref str i)) (lp (+ i 1)))))) - (apply string-map (lambda (ch) (proc ch) ch) str los))) - (define (bytevector-copy bv) (let ((res (make-bytevector (bytevector-length bv)))) (bytevector-copy! bv res)