altos/scheme: Add vector and string funcs. Test everybody.

[fw/altos] / src / scheme / ao_scheme_string.scheme

diff --git a/src/scheme/ao_scheme_string.scheme b/src/scheme/ao_scheme_string.scheme
new file mode 100644 (file)
index 0000000..10e6fa4
--- /dev/null
+++ b/src/scheme/ao_scheme_string.scheme
@@ -0,0 +1,152 @@
+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+; General Public License for more details.
+;
+; string functions placed in ROM
+
+(define string-map
+  (lambda (proc . strings)
+                                       ; result length is min of arg lengths
+    (let* ((l (apply min (map string-length strings)))
+                                       ; create the result
+          (s (make-string l)))
+                                       ; walk the strings, doing evaluation
+      (define (_m p)
+       (if (equal? p l)
+           s
+           (begin
+             (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings)))
+             (_m (+ p 1))
+             )
+           )
+       )
+      (_m 0)
+      )
+    )
+  )
+
+(_??_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM")
+
+(define string-copy!
+  (lambda (t a f . args)
+    (let ((l 0)
+         (h (string-length f))
+         (o a)
+         (d 1))
+                                       ; handle optional start/end args
+      
+      (if (not (null? args))
+         (begin
+           (set! l (car args))
+           (if (not (null? (cdr args)))
+               (set! h (cadr args)))
+           (set! o (- a l))
+           )
+         )
+                                       ; flip copy order if dst is
+                                       ; after src
+      (if (< l a)
+         (begin
+           (set! d h)
+           (set! h (- l 1))
+           (set! l (- d 1))
+           (set! d -1)
+           )
+         )
+                                       ; loop copying one at a time
+      (do ((p l (+ p d))
+          )
+         ((= p h) t)
+       (string-set! t (+ p o) (string-ref f p))
+       )
+      )
+    )
+  )
+
+(_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
+(_??_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello    ")
+(_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
+
+(define (string-upcase s) (string-map char-upcase s))
+(define (string-downcase s) (string-map char-downcase s))
+(define string-foldcase string-downcase)
+
+(define string-copy
+  (lambda (s . args)
+    (let ((l 0)
+         (h (string-length s)))
+      (if (not (null? args))
+         (begin
+           (set! l (car args))
+           (if (not (null? (cdr args)))
+               (set! h (cadr args)))
+           )
+         )
+      (string-copy! (make-string (- h l)) 0 s l h)
+      )
+    )
+  )
+
+(_??_ (string-copy "hello" 0 1) "h")
+(_??_ (string-copy "hello" 1) "ello")
+(_??_ (string-copy "hello") "hello")
+
+(define substring string-copy)
+
+(define string-fill!
+  (lambda (s a . args)
+    (let ((l 0)
+         (h (string-length s)))
+      (cond ((not (null? args))
+            (set! l (car args))
+            (cond ((not (null? (cdr args)))
+                   (set! h (cadr args)))
+                  )
+            )
+           )
+      (define (_f b)
+       (cond ((< b h)
+              (string-set! s b a)
+              (_f (+ b 1))
+              )
+             (else s)
+             )
+       )
+      (_f l)
+      )
+    )
+  )
+
+(_??_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa")
+(_??_ (string-fill! (make-string 10) #\a 1 2) " a        ")
+
+(define string-for-each
+  (lambda (proc . strings)
+                                       ; result length is min of arg lengths
+    (let* ((l (apply min (map string-length strings)))
+          )
+                                       ; walk the strings, doing evaluation
+      (define (_m p)
+       (if (equal? p l)
+           #t
+           (begin
+             (apply proc (map (lambda (s) (string-ref s p)) strings))
+             (_m (+ p 1))
+             )
+           )
+       )
+      (_m 0)
+      )
+    )
+  )
+
+(_??_ (string-for-each write-char "IBM\n") #t)