add missing string functions

This commit is contained in:
Yuichi Nishiwaki 2013-11-18 01:26:03 +09:00
parent 0d952d3639
commit 7fbff9384e
2 changed files with 63 additions and 1 deletions

View File

@ -69,7 +69,7 @@
| 6.4 Pairs and lists | yes | |
| 6.5 Symbols | yes | |
| 6.6 Characters | yes | |
| 6.7 Strings | incomplete | TODO: almost all functions in the section :-( |
| 6.7 Strings | yes | `substring` is not provided |
| 6.8 Vectors | incomplete | string->vector, vector->string, ...etc |
| 6.9 Bytevectors | incomplete | TODO: string<->utf8 conversion, etc |
| 6.10 Control features | incomplete | TODO: `string-map`, `vector-map`, ...etc |

View File

@ -379,6 +379,68 @@
(define-char-transitive-predicate char<=? <=)
(define-char-transitive-predicate char>=? >=)
;;; 6.7 String
(define (string . objs)
(let ((len (length objs)))
(let ((v (make-string len)))
(do ((i 0 (+ i 1))
(l objs (cdr l)))
((< i len)
v)
(string-set! v i (car l))))))
(define (string->list string . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length string))))
(do ((i start (+ i 1))
(res '()))
((< i end)
(reverse res))
(set! res (cons (string-ref string i) res)))))
(define (list->string list)
(apply string list))
(define (string-copy! to at from . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length from))))
(do ((i at (+ i 1))
(j start (+ j 1)))
((< j end))
(string-set! to i (string-ref from j)))))
(define (string-copy v . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length v))))
(let ((res (make-string (string-length v))))
(string-copy! res 0 v start end)
res)))
(define (string-append . vs)
(define (string-append-2-inv w v)
(let ((res (make-string (+ (string-length v) (string-length w)))))
(string-copy! res 0 v)
(string-copy! res (string-length v) w)
res))
(fold string-append-2-inv #() vs))
(define (string-fill! v fill . opts)
(let ((start (if (pair? opts) (car opts) 0))
(end (if (>= (length opts) 2)
(cadr opts)
(string-length v))))
(do ((i start (+ i 1)))
((< i end)
#f)
(string-set! v i fill))))
;;; 6.8. Vector
(define (vector . objs)