altos/lisp: Fix some scheme compat issues

flush -> flush-output
nth -> list-ref (oh, and add list-tail)
add let* (same as let for now)
write control chars in octal
make hanoi example work

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

diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index ccd13d075604467018cf6eb344f0c7cdc3941b9c..e5370f9037bd4379aac7aaa12d573fb967f21401 100644 (file)
--- a/src/lisp/ao_lisp_builtin.c
+++ b/src/lisp/ao_lisp_builtin.c
@@ -533,9 +533,9 @@ ao_lisp_do_string_to_list(struct ao_lisp_cons *cons)
 }
 
 ao_poly
-ao_lisp_do_flush(struct ao_lisp_cons *cons)
+ao_lisp_do_flush_output(struct ao_lisp_cons *cons)
 {
-       if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0))
+       if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0))
                return AO_LISP_NIL;
        ao_lisp_os_flush();
        return _ao_lisp_bool_true;

diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt
index 4c48433767646c26e5c924023b5c772aa447d090..c324ca67018d8f45a43999d9fbc3a075d7e74973 100644 (file)
--- a/src/lisp/ao_lisp_builtin.txt
+++ b/src/lisp/ao_lisp_builtin.txt
@@ -31,7 +31,7 @@ f_lexpr               less_equal      <=
 f_lexpr                greater_equal   >=
 f_lambda       list_to_string          list->string
 f_lambda       string_to_list          string->list
-f_lambda       flush
+f_lambda       flush_output            flush-output
 f_lambda       delay
 f_lexpr                led
 f_lambda       save

diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp
index 191ef00581ff2b602fa3a295cb1455fb2601a258..861a4fc80eed91314a76453f63528fef4d21340e 100644 (file)
--- a/src/lisp/ao_lisp_const.lisp
+++ b/src/lisp/ao_lisp_const.lisp
@@ -60,10 +60,17 @@
 
 (defun caddr (l) (car (cdr (cdr l))))
 
-(defun nth (list n)
-  (cond ((= n 0) (car list))
-       ((nth (cdr list) (1- n)))
-       )
+(define list-tail (lambda (x k)
+                   (if (zero? k)
+                       x
+                     (list-tail (cdr x (- k 1)))
+                     )
+                   )
+  )
+
+(define list-ref (lambda (x k)
+                  (car (list-tail x k))
+                  )
   )
 
                                        ; simple math operators
@@ -264,6 +271,7 @@
 
 (let ((x 1)) x)
 
+(define let* let)
                                        ; boolean operators
 
 (define or (lexpr (l)

diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c
index fff218dfafaaa669fd425f1d8800967a48786323..1daa50ea968f70ec211e9d487367ad7a58524aa3 100644 (file)
--- a/src/lisp/ao_lisp_string.c
+++ b/src/lisp/ao_lisp_string.c
@@ -140,7 +140,10 @@ ao_lisp_string_write(ao_poly p)
                        printf ("\\t");
                        break;
                default:
-                       putchar(c);
+                       if (c < ' ')
+                               printf("\\%03o", c);
+                       else
+                               putchar(c);
                        break;
                }
        }

diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp
index e2eb0fa00854dd3732496ca02e210feb8d142fc5..e873c796e4718d50f6ee4003af10baaedf6b0800 100644 (file)
--- a/src/test/hanoi.lisp
+++ b/src/test/hanoi.lisp
@@ -16,129 +16,133 @@
 
                                        ; ANSI control sequences
 
-(defun move-to (col row)
-  (patom "\033[" row ";" col "H")
+(define move-to (lambda (col row)
+                 (for-each display (list "\033[" row ";" col "H"))
+                 )
   )
 
-(defun clear ()
-  (patom "\033[2J")
+(define clear (lambda ()
+               (display "\033[2J")
+               )
   )
 
-(defun display-string (x y str)
-  (move-to x y)
-  (patom str)
+(define display-string (lambda (x y str)
+                        (move-to x y)
+                        (display str)
+                        )
   )
 
                                        ; Here's the pieces to display
 
-(setq stack '("     *     " "    ***    " "   *****   " "  *******  " " ********* " "***********"))
+(define tower '("     *     " "    ***    " "   *****   " "  *******  " " ********* " "***********"))
 
-                                       ; Here's all of the stacks of pieces
+                                       ; Here's all of the towers of pieces
                                        ; This is generated when the program is run
 
-(setq stacks nil)
+(define towers ())
 
-                                       ; Display one stack, clearing any
+(define 1- (lambda (x) (- x 1)))
+                                       ; Display one tower, clearing any
                                        ; space above it
 
-(defun display-stack (x y clear stack)
-  (cond ((= 0 clear)
-        (cond (stack 
-               (display-string x y (car stack))
-               (display-stack x (1+ y) 0 (cdr stack))
-               )
-              )
-        )
-       (t 
-        (display-string x y "                   ")
-        (display-stack x (1+ y) (1- clear) stack)
-        )
-       )
+(define display-tower (lambda (x y clear tower)
+                       (cond ((= 0 clear)
+                              (cond ((not (null? tower))
+                                     (display-string x y (car tower))
+                                     (display-tower x (1+ y) 0 (cdr tower))
+                                     )
+                                    )
+                              )
+                             (else 
+                              (display-string x y "                   ")
+                              (display-tower x (1+ y) (1- clear) tower)
+                              )
+                             )
+                       )
   )
 
-                                       ; Position of the top of the stack on the screen
-                                       ; Shorter stacks start further down the screen
+                                       ; Position of the top of the tower on the screen
+                                       ; Shorter towers start further down the screen
 
-(defun stack-pos (y stack)
-  (- y (length stack))
+(define tower-pos (lambda (y tower)
+                   (- y (length tower))
+                   )
   )
 
-                                       ; Display all of the stacks, spaced 20 columns apart
+                                       ; Display all of the towers, spaced 20 columns apart
 
-(defun display-stacks (x y stacks)
-  (cond (stacks
-        (display-stack x 0 (stack-pos y (car stacks)) (car stacks))
-        (display-stacks (+ x 20) y (cdr stacks)))
-       )
+(define display-towers (lambda (x y towers)
+                        (cond ((not (null? towers))
+                               (display-tower x 0 (tower-pos y (car towers)) (car towers))
+                               (display-towers (+ x 20) y (cdr towers)))
+                              )
+                        )
   )
 
-                                       ; Display all of the stacks, then move the cursor
+(define top 0)
+                                       ; Display all of the towers, then move the cursor
                                        ; out of the way and flush the output
 
-(defun display ()
-  (display-stacks 0 top stacks)
-  (move-to 1 21)
-  (flush)
+(define display-hanoi (lambda ()
+                       (display-towers 0 top towers)
+                       (move-to 1 21)
+                       (flush-output)
+                       )
   )
 
-                                       ; Reset stacks to the starting state, with
-                                       ; all of the pieces in the first stack and the
+                                       ; Reset towers to the starting state, with
+                                       ; all of the pieces in the first tower and the
                                        ; other two empty
 
-(defun reset-stacks ()
-  (setq stacks (list stack nil nil))
-  (setq top (+ (length stack) 3))
-  (length stack)
-  )
-
-                                       ; more functions which could usefully
-                                       ; be in the rom image
-
-(defun min (a b)
-  (cond ((< a b) a)
-       (b)
-       )
+(define reset-towers (lambda ()
+                      (set! towers (list tower () ()))
+                      (set! top (+ (length tower) 3))
+                      (length tower)
+                      )
   )
 
-                                       ; Replace a stack in the list of stacks
+                                       ; Replace a tower in the list of towers
                                        ; with a new value
 
-(defun replace (list pos member)
-  (cond ((= pos 0) (cons member (cdr list)))
-       ((cons (car list) (replace (cdr list) (1- pos) member)))
-       )
+(define replace (lambda (list pos member)
+                 (cond ((= pos 0) (cons member (cdr list)))
+                       ((cons (car list) (replace (cdr list) (1- pos) member)))
+                       )
+                 )
   )
 
-                                       ; Move a piece from the top of one stack
+                                       ; Move a piece from the top of one tower
                                        ; to the top of another
 
-(setq move-delay 100)
-
-(defun move-piece (from to)
-  (let ((from-stack (nth stacks from))
-       (to-stack (nth stacks to))
-       (piece (car from-stack)))
-    (setq from-stack (cdr from-stack))
-    (setq to-stack (cons piece to-stack))
-    (setq stacks (replace stacks from from-stack))
-    (setq stacks (replace stacks to to-stack))
-    (display)
-    (delay move-delay)
-    )
+(define move-delay 10)
+
+(define move-piece (lambda (from to)
+                    (let* ((from-tower (list-ref towers from))
+                          (to-tower (list-ref towers to))
+                          (piece (car from-tower)))
+                      (set! from-tower (cdr from-tower))
+                      (set! to-tower (cons piece to-tower))
+                      (set! towers (replace towers from from-tower))
+                      (set! towers (replace towers to to-tower))
+                      (display-hanoi)
+;                     (delay move-delay)
+                      )
+                    )
   )
 
 ; The implementation of the game
 
-(defun _hanoi (n from to use)
-  (cond ((= 1 n)
-        (move-piece from to)
-        )
-       (t
-        (_hanoi (1- n) from use to)
-        (_hanoi 1 from to use)
-        (_hanoi (1- n) use to from)
-        )
-       )
+(define _hanoi (lambda (n from to use)
+                (cond ((= 1 n)
+                       (move-piece from to)
+                       )
+                      (else
+                       (_hanoi (1- n) from use to)
+                       (_hanoi 1 from to use)
+                       (_hanoi (1- n) use to from)
+                       )
+                      )
+                )
   )
 
                                        ; A pretty interface which
@@ -146,10 +150,13 @@
                                        ; clears the screen and runs
                                        ; the program
 
-(defun hanoi ()
-  (setq len (reset-stacks))
-  (clear)
-  (_hanoi len 0 1 2)
-  (move-to 0 23)
-  t
+(define hanoi (lambda ()
+               (let ((len))
+                 (set! len (reset-towers))
+                 (clear)
+                 (_hanoi len 0 1 2)
+                 (move-to 0 23)
+                 #t
+                 )
+               )
   )