From 4c0ce778929b4183a46662e97c0df04f1587dcfd Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Tue, 28 Jul 2015 21:34:55 -0400
Subject: [PATCH] Added more string functions

---
 TODO            |  5 +++++
 scheme/base.sld | 39 +++++++++++++++++++++++++++++++++++++--
 2 files changed, 42 insertions(+), 2 deletions(-)

diff --git a/TODO b/TODO
index c92fe17d..fc583dcd 100644
--- a/TODO
+++ b/TODO
@@ -7,6 +7,11 @@ Working TODO list. should start creating issues for these to get them out of her
 
  - self-hosting, there are a lot of accumulated TODO's that need to be addressed
 
+   - adding r7rs support
+     - vectors - add test cases from r7rs
+     - strings - finish adding functions, then add test cases
+     - review other sections from the report
+
    - improved error handling:
      - param count checks
        if a primitive is called directly, shouldn't it be possible to check arg count?
diff --git a/scheme/base.sld b/scheme/base.sld
index d6cddf3a..67ca08de 100644
--- a/scheme/base.sld
+++ b/scheme/base.sld
@@ -40,8 +40,6 @@
     boolean=?
     symbol=?
     Cyc-obj=?
-    make-string
-    string
     vector
     vector-append
     vector-copy
@@ -49,8 +47,17 @@
     vector-fill!
     vector->list
     vector->string
+    make-string
+    string
+    string-copy
+    string-copy!
+    string-fill!
     my-string->list
     string->vector
+    ; TODO:
+    ;string-upcase
+    ;string-downcase
+    ;string-foldcase
     make-parameter
     current-output-port
     current-input-port
@@ -217,6 +224,7 @@
     (define (vector->string vec . opts)
       (let ((lst (apply vector->list (cons vec opts))))
         (list->string lst)))
+    ;; TODO: change to string->list
     (define (my-string->list str . opts)
       (letrec ((len (string-length str))
                (start (if (> (length opts) 0) (car opts) 0))
@@ -232,6 +240,33 @@
     (define (string->vector str . opts)
       (list->vector
         (string->list str)))
+    (define (string-copy str . opts)
+      (letrec ((len (string-length str))
+               (start (if (> (length opts) 0) (car opts) 0))
+               (end (if (> (length opts) 1) (cadr opts) len)))
+        (substring str start end)))
+    (define (string-copy! to at from . opts)
+      (letrec ((len (string-length from))
+               (start (if (> (length opts) 0) (car opts) 0))
+               (end (if (> (length opts) 1) (cadr opts) len))
+               (loop (lambda (i-at i-from)
+                       (cond
+                        ((= i-from end) to)
+                        (else
+                          (string-set! to i-at (string-ref from i-from))
+                          (loop (+ i-at 1) (+ i-from 1)))))))
+        (loop at start)))
+    (define (string-fill! str fill . opts)
+      (letrec ((len (string-length str))
+               (start (if (> (length opts) 0) (car opts) 0))
+               (end (if (> (length opts) 1) (cadr opts) len))
+               (loop (lambda (i)
+                       (cond
+                        ((= i end) str)
+                        (else
+                          (string-set! str i fill)
+                          (loop (+ i 1)))))))
+        (loop start)))
     (define (vector-append . vecs)
       (list->vector
         (apply append (map vector->list vecs))))