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>

1 files changed, 214 insertions, 131 deletions

diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme
index 29f000b3..107d60a6 100644
--- a/src/scheme/ao_scheme_const.scheme
+++ b/src/scheme/ao_scheme_const.scheme
@@ -13,6 +13,8 @@
 ;
 ; 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))
 
@@ -80,7 +82,7 @@
 
 					; execute to resolve macros
 
-(or #f #t)
+(_?_ (or #f #t) #t)
 
 (begin
  (def! and
@@ -109,7 +111,43 @@
 
 					; 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
@@ -275,12 +313,24 @@
 
 (define (caar l) (car (car l)))
 
+(_??_ (caar '((1 2 3) (4 5 6))) 1)
+
 (define (cadr l) (car (cdr l)))
 
+(_??_ (cadr '(1 2 3 4 5 6)) 2)
+
 (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))))
 
+(_??_ (caddr '(1 2 3 4)) 3)
+
 					; (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)))
 
-(zero? 1)
-(zero? 0)
-(zero? "hello")
+(_??_ (zero? 1) #f)
+(_??_ (zero? 0) #t)
+(_??_ (zero? "hello") #f)
 
 (define positive? (macro (value) `(> ,value 0)))
 
-(positive? 12)
-(positive? -12)
+(_??_ (positive? 12) #t)
+(_??_ (positive? -12) #f)
 
 (define negative? (macro (value) `(< ,value 0)))
 
-(negative? 12)
-(negative? -12)
+(_??_ (negative? 12) #f)
+(_??_ (negative? -12) #t)
 
 (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))
@@ -335,8 +385,8 @@
 		   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))
@@ -348,35 +398,37 @@
 		   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)))
 
-(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)))
 
-(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))
   )
 
+(_??_ (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
@@ -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
@@ -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))))
 
-(when #t (write 'when))
+(_??_ (when #t (+ 1 2)) 3)
+(_??_ (when #f (+ 1 2)) #f)
 
 (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)
@@ -521,33 +575,27 @@
   (_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)
@@ -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?))
 
-(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?))
 
-(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 (test? obj (caar list))
+    (if (compare obj (caar 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?)
 
-(char? #\q)
-(char? "h")
+(_??_ (char? #\q) #t)
+(_??_ (char? "h") #f)
 
 (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))
 
-(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)))
 
-(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))
 
-(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)))
 
-(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))
 
-(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))
 
-(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)))
 
-(display "apply\n")
-(apply cons '(a b))
+(_??_ (string #\a #\b #\c) "abc")
+
+(_??_ (apply cons '(a b)) '(a . b))
 
 (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)
@@ -708,23 +769,6 @@
 
 (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)
@@ -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
@@ -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))