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

Add a bunch of string and vector functions from r7rs. I think most
everything is here now.

Signed-off-by: Keith Packard <keithp@keithp.com>

diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc
index 1a080a4ee068024cdaf32fbe00d183cee4332d70..db5083df055bf1769f3ebd5298b96a4986af523f 100644 (file)
--- a/src/scheme/Makefile-inc
+++ b/src/scheme/Makefile-inc
@@ -23,3 +23,8 @@ SCHEME_HDRS=\
        ao_scheme_os.h \
        ao_scheme_read.h \
        ao_scheme_builtin.h
        ao_scheme_os.h \
        ao_scheme_read.h \
        ao_scheme_builtin.h

+
+SCHEME_SCHEME=\
+       ao_scheme_const.scheme \
+       ao_scheme_vector.scheme \
+       ao_scheme_string.scheme

diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme
index 29f000b3c58c976a6513a72a42f3246183c673fe..107d60a61f0b0fe7f9b6849a58cf1b769aebafb1 100644 (file)
--- a/src/scheme/ao_scheme_const.scheme
+++ b/src/scheme/ao_scheme_const.scheme
@@ -13,6 +13,8 @@
 ;
 ; Lisp code placed in ROM
 
 ;
 ; Lisp code placed in ROM
 

+(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit)))))
+

                                        ; return a list containing all of the arguments
 (def (quote list) (lambda l l))
 
                                        ; return a list containing all of the arguments
 (def (quote list) (lambda l l))
 


@@ -80,7 +82,7 @@
 
                                        ; execute to resolve macros
 
 
                                        ; execute to resolve macros
 

-(or #f #t)
+(_?_ (or #f #t) #t)

 
 (begin
  (def! and
 
 (begin
  (def! and


@@ -109,7 +111,43 @@
 
                                        ; execute to resolve macros
 
 
                                        ; execute to resolve macros
 

-(and #t #f)
+(_?_ (and #t #f) #f)
+
+                                       ; recursive equality
+
+(begin
+  (def! equal?
+    (lambda (a b)
+      (cond ((eq? a b) #t)
+           ((and (pair? a) (pair? b))
+            (and (equal? (car a) (car b))
+                 (equal? (cdr a) (cdr b)))
+            )
+           ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
+            ((lambda (i l)
+               (while (and (< i l)
+                           (equal? (vector-ref a i)
+                                   (vector-ref b i)))
+                      (set! i (+ i 1)))
+               (eq? i l)
+               )
+             0
+             (vector-length a)
+             )
+            )
+           (else #f)
+           )
+      )
+    )
+  'equal?
+  )
+
+(_?_ (equal? '(a b c) '(a b c)) #t)
+(_?_ (equal? '(a b c) '(a b b)) #f)
+(_?_ (equal? #(1 2 3) #(1 2 3)) #t)
+(_?_ (equal? #(1 2 3) #(4 5 6)) #f)
+
+(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit)))))

 
 (begin
  (def! quasiquote
 
 (begin
  (def! quasiquote


@@ -275,12 +313,24 @@
 
 (define (caar l) (car (car l)))
 
 
 (define (caar l) (car (car l)))
 

+(_??_ (caar '((1 2 3) (4 5 6))) 1)
+

 (define (cadr l) (car (cdr l)))
 
 (define (cadr l) (car (cdr l)))
 

+(_??_ (cadr '(1 2 3 4 5 6)) 2)
+

 (define (cdar l) (cdr (car l)))
 
 (define (cdar l) (cdr (car l)))
 

+(_??_ (cdar '((1 2) (3 4))) '(2))
+
+(define (cddr l) (cdr (cdr l)))
+
+(_??_ (cddr '(1 2 3)) '(3))
+

 (define (caddr l) (car (cdr (cdr l))))
 
 (define (caddr l) (car (cdr (cdr l))))
 

+(_??_ (caddr '(1 2 3 4)) 3)
+

                                        ; (if <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)
 
                                        ; (if <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)
 


@@ -297,33 +347,33 @@
         )
   )
 
         )
   )
 

-(if (> 3 2) 'yes)
-(if (> 3 2) 'yes 'no)
-(if (> 2 3) 'no 'yes)
-(if (> 2 3) 'no)
+(_??_ (if (> 3 2) 'yes) 'yes)
+(_??_ (if (> 3 2) 'yes 'no) 'yes)
+(_??_ (if (> 2 3) 'no 'yes) 'yes)
+(_??_ (if (> 2 3) 'no) #f)

 
                                        ; simple math operators
 
 (define zero? (macro (value) `(eq? ,value 0)))
 
 
                                        ; simple math operators
 
 (define zero? (macro (value) `(eq? ,value 0)))
 

-(zero? 1)
-(zero? 0)
-(zero? "hello")
+(_??_ (zero? 1) #f)
+(_??_ (zero? 0) #t)
+(_??_ (zero? "hello") #f)

 
 (define positive? (macro (value) `(> ,value 0)))
 
 
 (define positive? (macro (value) `(> ,value 0)))
 

-(positive? 12)
-(positive? -12)
+(_??_ (positive? 12) #t)
+(_??_ (positive? -12) #f)

 
 (define negative? (macro (value) `(< ,value 0)))
 
 
 (define negative? (macro (value) `(< ,value 0)))
 

-(negative? 12)
-(negative? -12)
+(_??_ (negative? 12) #f)
+(_??_ (negative? -12) #t)

 
 (define (abs x) (if (>= x 0) x (- x)))
 
 
 (define (abs x) (if (>= x 0) x (- x)))
 

-(abs 12)
-(abs -12)
+(_??_ (abs 12) 12)
+(_??_ (abs -12) 12)

 
 (define max (lambda (first . rest)
                   (while (not (null? rest))
 
 (define max (lambda (first . rest)
                   (while (not (null? rest))


@@ -335,8 +385,8 @@
                   first)
   )
 
                   first)
   )
 

-(max 1 2 3)
-(max 3 2 1)
+(_??_ (max 1 2 3) 3)
+(_??_ (max 3 2 1) 3)

 
 (define min (lambda (first . rest)
                   (while (not (null? rest))
 
 (define min (lambda (first . rest)
                   (while (not (null? rest))


@@ -348,35 +398,37 @@
                   first)
   )
 
                   first)
   )
 

-(min 1 2 3)
-(min 3 2 1)
+(_??_ (min 1 2 3) 1)
+(_??_ (min 3 2 1) 1)

 
 (define (even? x) (zero? (% x 2)))
 
 
 (define (even? x) (zero? (% x 2)))
 

-(even? 2)
-(even? -2)
-(even? 3)
-(even? -1)
+(_??_ (even? 2) #t)
+(_??_ (even? -2) #t)
+(_??_ (even? 3) #f)
+(_??_ (even? -1) #f)

 
 (define (odd? x) (not (even? x)))
 
 
 (define (odd? x) (not (even? x)))
 

-(odd? 2)
-(odd? -2)
-(odd? 3)
-(odd? -1)
-
+(_??_ (odd? 2) #f)
+(_??_ (odd? -2) #f)
+(_??_ (odd? 3) #t)
+(_??_ (odd? -1) #t)

 
 

-(define (list-tail x k)
-  (if (zero? k)
-      x
-    (list-tail (cdr x (- k 1)))
-    )
-  )
+(_??_ (list-tail '(1 2 3 . 4) 3) 4)

 
 (define (list-ref x k)
   (car (list-tail x k))
   )
 
 
 (define (list-ref x k)
   (car (list-tail x k))
   )
 

+(_??_ (list-ref '(1 2 3 4) 3) 4)
+
+(define (list-set! x k v)
+  (set-car! (list-tail x k) v)
+  x)
+
+(list-set! (list 1 2 3) 1 4)
+

                                        ; define a set of local
                                        ; variables all at once and
                                        ; then evaluate a list of
                                        ; define a set of local
                                        ; variables all at once and
                                        ; then evaluate a list of


@@ -429,7 +481,7 @@
      )
                   
 
      )
                   
 

-(let ((x 1) (y)) (set! y 2) (+ x y))
+(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)

 
                                        ; define a set of local
                                        ; variables one at a time and
 
                                        ; define a set of local
                                        ; variables one at a time and


@@ -501,15 +553,17 @@
         )
      )
 
         )
      )
 

-(let* ((x 1) (y x)) (+ x y))
+(_??_ (let* ((x 1) (y x)) (+ x y)) 2)

 
 (define when (macro (test . l) `(cond (,test ,@l))))
 
 
 (define when (macro (test . l) `(cond (,test ,@l))))
 

-(when #t (write 'when))
+(_??_ (when #t (+ 1 2)) 3)
+(_??_ (when #f (+ 1 2)) #f)

 
 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
 
 
 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
 

-(unless #f (write 'unless))
+(_??_ (unless #f (+ 2 3)) 5)
+(_??_ (unless #t (+ 2 3)) #f)

 
 (define (reverse list)
   (define (_r old new)
 
 (define (reverse list)
   (define (_r old new)


@@ -521,33 +575,27 @@
   (_r list ())
   )
 
   (_r list ())
   )
 

-(reverse '(1 2 3))
-
-(define (list-tail x k)
-  (if (zero? k)
-      x
-    (list-tail (cdr x) (- k 1))))
-
-(list-tail '(1 2 3) 2)
-
-(define (list-ref x k) (car (list-tail x k)))
-
-(list-ref '(1 2 3) 2)
-    
-                                       ; recursive equality
+(_??_ (reverse '(1 2 3)) '(3 2 1))

 
 

-(define (equal? a b)
-  (cond ((eq? a b) #t)
-       ((and (pair? a) (pair? b))
-        (and (equal? (car a) (car b))
-             (equal? (cdr a) (cdr b)))
-        )
-       (else #f)
+(define make-list
+  (lambda (a . b)
+    (define (_m a x)
+      (if (zero? a)
+         x
+         (_m (- a 1) (cons b x))
+         )
+      )
+    (if (null? b)
+       (set! b #f)
+       (set! b (car b))

        )
        )

+    (_m a '())
+    )

   )
   )

+    
+(_??_ (make-list 10 'a) '(a a a a a a a a a a))

 
 

-(equal? '(a b c) '(a b c))
-(equal? '(a b c) '(a b b))
+(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))

 
 (define member (lambda (obj list . test?)
                      (cond ((null? list)
 
 (define member (lambda (obj list . test?)
                      (cond ((null? list)


@@ -563,105 +611,118 @@
                      )
   )
 
                      )
   )
 

-(member '(2) '((1) (2) (3)))
+(_??_ (member '(2) '((1) (2) (3)))  '((2) (3)))

 
 

-(member '(4) '((1) (2) (3)))
+(_??_ (member '(4) '((1) (2) (3))) #f)

 
 (define (memq obj list) (member obj list eq?))
 
 
 (define (memq obj list) (member obj list eq?))
 

-(memq 2 '(1 2 3))
+(_??_ (memq 2 '(1 2 3)) '(2 3))

 
 

-(memq 4 '(1 2 3))
+(_??_ (memq 4 '(1 2 3)) #f)

 
 

-(memq '(2) '((1) (2) (3)))
+(_??_ (memq '(2) '((1) (2) (3))) #f)

 
 (define (memv obj list) (member obj list eqv?))
 
 
 (define (memv obj list) (member obj list eqv?))
 

-(memv 2 '(1 2 3))
+(_??_ (memv 2 '(1 2 3)) '(2 3))

 
 

-(memv 4 '(1 2 3))
+(_??_ (memv 4 '(1 2 3)) #f)

 
 

-(memv '(2) '((1) (2) (3)))
+(_??_ (memv '(2) '((1) (2) (3))) #f)

 
 

-(define (_assoc obj list test?)
+(define (assoc obj list . compare)
+  (if (null? compare)
+      (set! compare equal?)
+      (set! compare (car compare))
+      )

   (if (null? list)
       #f
   (if (null? list)
       #f

-    (if (test? obj (caar list))
+    (if (compare obj (caar list))

        (car list)
        (car list)

-      (_assoc obj (cdr list) test?)
-      )
+       (assoc obj (cdr list) compare)
+       )

     )
   )
 
     )
   )
 

-(define (assq obj list) (_assoc obj list eq?))
-(define (assv obj list) (_assoc obj list eqv?))
-(define (assoc obj list) (_assoc obj list equal?))
+(define (assq obj list) (assoc obj list eq?))
+(define (assv obj list) (assoc obj list eqv?))

 
 

-(assq 'a '((a 1) (b 2) (c 3)))
-(assv 'b '((a 1) (b 2) (c 3)))
-(assoc '(c) '((a 1) (b 2) ((c) 3)))
+(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
+(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
+(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))

 
 (define char? integer?)
 
 
 (define char? integer?)
 

-(char? #\q)
-(char? "h")
+(_??_ (char? #\q) #t)
+(_??_ (char? "h") #f)

 
 (define (char-upper-case? c) (<= #\A c #\Z))
 
 
 (define (char-upper-case? c) (<= #\A c #\Z))
 

-(char-upper-case? #\a)
-(char-upper-case? #\B)
-(char-upper-case? #\0)
-(char-upper-case? #\space)
+(_??_ (char-upper-case? #\a) #f)
+(_??_ (char-upper-case? #\B) #t)
+(_??_ (char-upper-case? #\0) #f)
+(_??_ (char-upper-case? #\space) #f)

 
 (define (char-lower-case? c) (<= #\a c #\a))
 
 
 (define (char-lower-case? c) (<= #\a c #\a))
 

-(char-lower-case? #\a)
-(char-lower-case? #\B)
-(char-lower-case? #\0)
-(char-lower-case? #\space)
+(_??_ (char-lower-case? #\a) #t)
+(_??_ (char-lower-case? #\B) #f)
+(_??_ (char-lower-case? #\0) #f)
+(_??_ (char-lower-case? #\space) #f)

 
 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
 
 
 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
 

-(char-alphabetic? #\a)
-(char-alphabetic? #\B)
-(char-alphabetic? #\0)
-(char-alphabetic? #\space)
+(_??_ (char-alphabetic? #\a) #t)
+(_??_ (char-alphabetic? #\B) #t)
+(_??_ (char-alphabetic? #\0) #f)
+(_??_ (char-alphabetic? #\space) #f)

 
 (define (char-numeric? c) (<= #\0 c #\9))
 
 
 (define (char-numeric? c) (<= #\0 c #\9))
 

-(char-numeric? #\a)
-(char-numeric? #\B)
-(char-numeric? #\0)
-(char-numeric? #\space)
+(_??_ (char-numeric? #\a) #f)
+(_??_ (char-numeric? #\B) #f)
+(_??_ (char-numeric? #\0) #t)
+(_??_ (char-numeric? #\space) #f)

 
 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
 
 
 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
 

-(char-whitespace? #\a)
-(char-whitespace? #\B)
-(char-whitespace? #\0)
-(char-whitespace? #\space)
+(_??_ (char-whitespace? #\a) #f)
+(_??_ (char-whitespace? #\B) #f)
+(_??_ (char-whitespace? #\0) #f)
+(_??_ (char-whitespace? #\space) #t)

 
 (define char->integer (macro (v) v))
 (define integer->char char->integer)
 
 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
 
 
 (define char->integer (macro (v) v))
 (define integer->char char->integer)
 
 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
 

-(char-upcase #\a)
-(char-upcase #\B)
-(char-upcase #\0)
-(char-upcase #\space)
+(_??_ (char-upcase #\a) #\A)
+(_??_ (char-upcase #\B) #\B)
+(_??_ (char-upcase #\0) #\0)
+(_??_ (char-upcase #\space) #\space)

 
 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
 
 
 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
 

-(char-downcase #\a)
-(char-downcase #\B)
-(char-downcase #\0)
-(char-downcase #\space)
+(_??_ (char-downcase #\a) #\a)
+(_??_ (char-downcase #\B) #\b)
+(_??_ (char-downcase #\0) #\0)
+(_??_ (char-downcase #\space) #\space)
+
+(define (digit-value c)
+  (if (char-numeric? c)
+      (- c #\0)
+      #f)
+  )
+
+(_??_ (digit-value #\1) 1)
+(_??_ (digit-value #\a) #f)

 
 (define string (lambda chars (list->string chars)))
 
 
 (define string (lambda chars (list->string chars)))
 

-(display "apply\n")
-(apply cons '(a b))
+(_??_ (string #\a #\b #\c) "abc")
+
+(_??_ (apply cons '(a b)) '(a . b))

 
 (define map
   (lambda (proc . lists)
 
 (define map
   (lambda (proc . lists)


@@ -690,7 +751,7 @@
         )
   )
 
         )
   )
 

-(map cadr '((a b) (d e) (g h)))
+(_??_ (map cadr '((a b) (d e) (g h))) '(b e h))

 
 (define for-each
   (lambda (proc . lists)
 
 (define for-each
   (lambda (proc . lists)


@@ -708,23 +769,6 @@
 
 (for-each display '("hello" " " "world" "\n"))
 
 
 (for-each display '("hello" " " "world" "\n"))
 

-(define (_string-ml strings)
-  (if (null? strings) ()
-    (cons (string->list (car strings)) (_string-ml (cdr strings)))
-    )
-  )
-
-(define string-map (lambda (proc . strings)
-                         (list->string (apply map proc (_string-ml strings))))))
-
-(string-map (lambda (x) (+ 1 x)) "HAL")
-
-(define string-for-each
-  (lambda (proc . strings)
-    (apply for-each proc (_string-ml strings))))
-
-(string-for-each write-char "IBM\n")
-

 (define (newline) (write-char #\newline))
 
 (newline)
 (define (newline) (write-char #\newline))
 
 (newline)


@@ -746,7 +790,7 @@
 
 
 
 
 
 

-`(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
+(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))

 
 
 (define repeat
 
 
 (define repeat


@@ -816,4 +860,43 @@
         )
   )
 
         )
   )
 

-(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
+(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "one")
+(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "two")
+(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x) "three")) (12 "twelve") (else "else")) "three")
+(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "else")
+(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "twelve")
+
+(define do
+  (macro (vars test . cmds)
+    (define (_step v)
+      (if (null? v)
+         '()
+         (if (null? (cddr (car v)))
+             (_step (cdr v))
+             (cons `(set! ,(caar v) ,(caddr (car v)))
+                   (_step (cdr v))
+                   )
+             )
+         )
+      )
+    `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
+       (while (not ,(car test))
+             ,@cmds
+             ,@(_step vars)
+             )
+       ,@(cdr test)
+       )
+    )
+  )
+
+(do ((x 1 (+ x 1)))
+    ((= x 10) "done")
+  (display "x: ")
+  (write x)
+  (newline)
+  )
+
+(_??_ (do ((vec (make-vector 5))
+          (i 0 (+ i 1)))
+         ((= i 5) vec)
+       (vector-set! vec i i)) #(0 1 2 3 4))

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)

diff --git a/src/scheme/ao_scheme_vector.scheme b/src/scheme/ao_scheme_vector.scheme
new file mode 100644 (file)
index 0000000..bf40204
--- /dev/null
+++ b/src/scheme/ao_scheme_vector.scheme
@@ -0,0 +1,192 @@
+;
+; 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.
+;
+; vector functions placed in ROM
+
+
+(define vector->string
+  (lambda (v . args)
+    (let ((l 0)
+         (h (vector-length v)))
+      (if (not (null? args))
+         (begin
+           (set! l (car args))
+           (if (not (null? (cdr args)))
+               (set! h (cadr args)))
+           )
+         )
+      (do ((s (make-string (- h l)))
+          (p l (+ p 1))
+          )
+         ((= p h) s)
+       (string-set! s (- p l) (vector-ref v p))
+       )
+      )
+    )
+  )
+
+(_??_ (vector->string #(#\a #\b #\c) 0 2) "ab")
+
+(define string->vector
+  (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)))
+           )
+         )
+      (do ((v (make-vector (- h l)))
+          (p l (+ p 1))
+          )
+         ((= p h) v)
+       (vector-set! v (- p l) (string-ref s p))
+       )
+      )
+    )
+  )
+
+(_??_ (string->vector "hello" 0 2) #(#\h #\e))
+    
+(define vector-copy!
+  (lambda (t a f . args)
+    (let ((l 0)
+         (h (vector-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)
+       (vector-set! t (+ p o) (vector-ref f p))
+       )
+      )
+    )
+  )
+
+                                       ; simple vector-copy test
+
+(_??_ (vector-copy! (make-vector 10 "t") 0 (make-vector 5 "f") 0 5) #("f" "f" "f" "f" "f" "t" "t" "t" "t" "t"))
+
+(let ((v (vector 1 2 3 4 5 6 7 8 9 0)))
+  (vector-copy! v 1 v 0 2)
+  (display "v ") (write v) (newline)
+  )
+
+(define vector-copy
+  (lambda (v . args)
+    (let ((l 0)
+         (h (vector-length v)))
+      (if (not (null? args))
+         (begin
+           (set! l (car args))
+           (if (not (null? (cdr args)))
+               (set! h (cadr args)))
+           )
+         )
+      (vector-copy! (make-vector (- h l)) 0 v)
+      )
+    )
+  )
+
+(_??_ (vector-copy #(1 2 3) 0 3) #(1 2 3))
+
+(define vector-append
+  (lambda a
+    (define (_f v a p)
+      (if (null? a)
+         v
+         (begin
+           (vector-copy! v p (car a))
+           (_f v (cdr a) (+ p (vector-length (car a))))
+           )
+         )
+      )
+    (_f (make-vector (apply + (map vector-length a))) a 0)
+    )
+  )
+
+(_??_ (vector-append #(1 2 3) #(4 5 6) #(7 8 9)) #(1 2 3 4 5 6 7 8 9))
+
+(define vector-fill!
+  (lambda (v a . args)
+    (let ((l 0)
+         (h (vector-length v)))
+      (cond ((not (null? args))
+            (set! l (car args))
+            (cond ((not (null? (cdr args)))
+                   (set! h (cadr args)))
+                  )
+            )
+           )
+      (define (_f b)
+       (cond ((< b h)
+              (vector-set! v b a)
+              (_f (+ b 1))
+              )
+             (else v)
+             )
+       )
+      (_f l)
+      )
+    )
+  )
+
+(_??_ (vector-fill! (make-vector 3) #t 1 2) #(#f #t #f))
+
+                                       ; like 'map', but for vectors
+
+(define vector-map
+  (lambda (proc . vectors)
+                                       ; result length is min of arg lengths
+    (let* ((l (apply min (map vector-length vectors)))
+                                       ; create the result
+          (v (make-vector l)))
+                                       ; walk the vectors, doing evaluation
+      (define (_m p)
+       (if (equal? p l)
+           v
+           (begin
+             (vector-set! v p (apply proc (map (lambda (v) (vector-ref v p)) vectors)))
+             (_m (+ p 1))
+             )
+           )
+       )
+      (_m 0)
+      )
+    )
+  )
+    
+(_??_ (vector-map + #(1 2 3) #(4 5 6)) #(5 7 9))

diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile
index ee46118eba5fadb810544f57a2ceec7343efc030..8858f0f6e40a1c802f60f118e4d1fa39af9628b5 100644 (file)
--- a/src/scheme/test/Makefile
+++ b/src/scheme/test/Makefile
@@ -3,6 +3,8 @@ include ../Makefile-inc
 vpath %.o .
 vpath %.c ..
 vpath %.h ..
 vpath %.o .
 vpath %.c ..
 vpath %.h ..

+vpath %.scheme ..
+vpath ao_scheme_make_const ../make-const

 
 SRCS=$(SCHEME_SRCS) ao_scheme_test.c
 HDRS=$(SCHEME_HDRS) ao_scheme_const.h
 
 SRCS=$(SCHEME_SRCS) ao_scheme_test.c
 HDRS=$(SCHEME_HDRS) ao_scheme_const.h


@@ -20,8 +22,8 @@ ao-scheme: $(OBJS)
 
 $(OBJS): $(HDRS)
 
 
 $(OBJS): $(HDRS)
 

-ao_scheme_const.h: ../make-const/ao_scheme_make_const ../ao_scheme_const.scheme
-       ../make-const/ao_scheme_make_const -o $@ ../ao_scheme_const.scheme
+ao_scheme_const.h: ao_scheme_make_const $(SCHEME_SCHEME)
+       $^ -o $@

 
 clean::
        rm -f $(OBJS) ao-scheme ao_scheme_const.h
 
 clean::
        rm -f $(OBJS) ao-scheme ao_scheme_const.h