altos/lisp: Make let distinct from let*

[fw/altos] / src / lisp / ao_lisp_const.lisp

diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp
index f8a709799ff5b05b580246bc176910b4345545d2..5c1aa75be79f983bfdab5c019286feea9c82ac3a 100644 (file)
--- a/src/lisp/ao_lisp_const.lisp
+++ b/src/lisp/ao_lisp_const.lisp
@@ -14,107 +14,320 @@
 ; Lisp code placed in ROM
 
                                        ; return a list containing all of the arguments
 ; Lisp code placed in ROM
 
                                        ; return a list containing all of the arguments

-

 (set (quote list) (lexpr (l) l))
 
 (set (quote list) (lexpr (l) l))
 

-                                       ;
-                                       ; Define a variable without returning the value
-                                       ; Useful when defining functions to avoid
-                                       ; having lots of output generated
-                                       ;
+(set (quote set!)
+     (macro (name value rest)
+           (list
+            set
+            (list
+             quote
+             name)
+            value)
+           )
+     )

 
 

-(set (quote define) (macro (name val rest)
-                       (list
-                        'begin
-                        (list
-                         'set
-                         (list 'quote name)
-                         val)
-                        (list 'quote name)
-                        )
-                       )
+(set! append
+     (lexpr (args)
+           ((lambda (append-list append-lists)
+              (set! append-list
+                   (lambda (a b)
+                     (cond ((null? a) b)
+                           (else (cons (car a) (append-list (cdr a) b)))
+                           )
+                     )
+                   )
+              (set! append-lists
+                   (lambda (lists)
+                     (cond ((null? lists) lists)
+                           ((null? (cdr lists)) (car lists))
+                           (else (append-list (car lists) (append-lists (cdr lists))))
+                           )
+                     )
+                   )
+              (append-lists args)
+              ) () ())
+           )
+     )
+
+(append '(a b c) '(d e f) '(g h i))
+
+                                       ; boolean operators
+
+(set! or
+     (macro (l)
+           ((lambda (_or)
+              (set! _or
+                   (lambda (l)
+                     (cond ((null? l) #f)
+                           ((null? (cdr l))
+                            (car l))
+                           (else
+                            (list
+                             cond
+                             (list
+                              (car l))
+                             (list
+                              'else
+                              (_or (cdr l))
+                              )
+                             )
+                            )
+                           )
+                     )
+                   )
+              (_or l)) ())))
+
+                                       ; execute to resolve macros
+
+(or #f #t)
+
+
+(set! and
+     (macro (l)
+           ((lambda (_and)
+              (set! _and
+                   (lambda (l)
+                     (cond ((null? l) #t)
+                           ((null? (cdr l))
+                            (car l))
+                           (else
+                            (list
+                             cond
+                             (list
+                              (car l)
+                              (_and (cdr l))
+                              )
+                             )
+                            )
+                           )
+                     )
+                   )
+              (_and l)) ())
+           )

      )
 
      )
 

+
+                                       ; execute to resolve macros
+
+(and #t #f)
+
+(set! quasiquote
+  (macro (x rest)
+        ((lambda (constant? combine-skeletons expand-quasiquote)
+           (set! constant?
+                                       ; A constant value is either a pair starting with quote,
+                                       ; or anything which is neither a pair nor a symbol
+
+                (lambda (exp)
+                  (cond ((pair? exp)
+                         (eq? (car exp) 'quote)
+                         )
+                        (else
+                         (not (symbol? exp))
+                         )
+                        )
+                  )
+                )
+           (set! combine-skeletons
+                (lambda (left right exp)
+                  (cond
+                   ((and (constant? left) (constant? right)) 
+                    (cond ((and (eqv? (eval left) (car exp))
+                                (eqv? (eval right) (cdr exp)))
+                           (list 'quote exp)
+                           )
+                          (else
+                           (list 'quote (cons (eval left) (eval right)))
+                           )
+                          )
+                    )
+                   ((null? right)
+                    (list 'list left)
+                    )
+                   ((and (pair? right) (eq? (car right) 'list))
+                    (cons 'list (cons left (cdr right)))
+                    )
+                   (else
+                    (list 'cons left right)
+                    )
+                   )
+                  )
+                )
+
+           (set! expand-quasiquote
+                (lambda (exp nesting)
+                  (cond
+
+                                       ; non cons -- constants
+                                       ; themselves, others are
+                                       ; quoted
+
+                   ((not (pair? exp)) 
+                    (cond ((constant? exp)
+                           exp
+                           )
+                          (else
+                           (list 'quote exp)
+                           )
+                          )
+                    )
+
+                                       ; check for an unquote exp and
+                                       ; add the param unquoted
+
+                   ((and (eq? (car exp) 'unquote) (= (length exp) 2))
+                    (cond ((= nesting 0)
+                           (car (cdr exp))
+                           )
+                          (else
+                           (combine-skeletons ''unquote 
+                                              (expand-quasiquote (cdr exp) (- nesting 1))
+                                              exp))
+                          )
+                    )
+
+                                       ; nested quasi-quote --
+                                       ; construct the right
+                                       ; expression
+
+                   ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
+                    (combine-skeletons ''quasiquote 
+                                       (expand-quasiquote (cdr exp) (+ nesting 1))
+                                       exp))
+
+                                       ; check for an
+                                       ; unquote-splicing member,
+                                       ; compute the expansion of the
+                                       ; value and append the rest of
+                                       ; the quasiquote result to it
+
+                   ((and (pair? (car exp))
+                         (eq? (car (car exp)) 'unquote-splicing)
+                         (= (length (car exp)) 2))
+                    (cond ((= nesting 0)
+                           (list 'append (car (cdr (car exp)))
+                                 (expand-quasiquote (cdr exp) nesting))
+                           )
+                          (else
+                           (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
+                                              (expand-quasiquote (cdr exp) nesting)
+                                              exp))
+                          )
+                    )
+
+                                       ; for other lists, just glue
+                                       ; the expansion of the first
+                                       ; element to the expansion of
+                                       ; the rest of the list
+
+                   (else (combine-skeletons (expand-quasiquote (car exp) nesting)
+                                            (expand-quasiquote (cdr exp) nesting)
+                                            exp)
+                         )
+                   )
+                  )
+                )
+           (expand-quasiquote x 0)
+           ) () () ())
+        )
+  )

                                        ;
                                        ;

-                                       ; A slightly more convenient form
-                                       ; for defining lambdas.
+                                       ; Define a variable without returning the value
+                                       ; Useful when defining functions to avoid
+                                       ; having lots of output generated.

                                        ;
                                        ;

-                                       ; (defun <name> (<params>) s-exprs)
+                                       ; Also accepts the alternate
+                                       ; form for defining lambdas of
+                                       ; (define (name x y z) sexprs ...) 

                                        ;
 
                                        ;
 

-(define defun (macro (name args exprs)
-                 (list
-                  define
-                  name
-                  (cons 'lambda (cons args exprs))
+(set! define
+      (macro (first rest)
+
+                                       ; check for alternate lambda definition form
+
+            (cond ((list? first)
+                   (set! rest
+                         (append
+                          (list
+                           'lambda
+                           (cdr first))
+                          rest))
+                   (set! first (car first))
+                   )
+                  (else
+                   (set! rest (car rest))
+                   )

                   )
                   )

-                 )
-     )
+            `(begin
+              (set! ,first ,rest)
+              (quote ,first))
+            )
+      )

 
                                        ; basic list accessors
 
 
 
                                        ; basic list accessors
 
 

-(defun caar (l) (car (car l)))
+(define (caar l) (car (car l)))

 
 

-(defun cadr (l) (car (cdr l)))
+(define (cadr l) (car (cdr l)))

 
 

-(defun caddr (l) (car (cdr (cdr l))))
+(define (cdar l) (cdr (car l)))

 
 

-(define list-tail (lambda (x k)
-                   (if (zero? k)
-                       x
-                     (list-tail (cdr x (- k 1)))
-                     )
-                   )
-  )
+(define (caddr l) (car (cdr (cdr l))))

 
 

-(define list-ref (lambda (x k)
-                  (car (list-tail x k))
-                  )
+(define (list-tail x k)
+  (if (zero? k)
+      x
+    (list-tail (cdr x (- k 1)))
+    )

   )
 
   )
 

-                                       ; simple math operators
+(define (list-ref x k)
+  (car (list-tail x k))
+  )

 
 

-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
+                                       ; (if <condition> <if-true>)
+                                       ; (if <condition> <if-true> <if-false)

 
 

-(define zero? (macro (value rest)
-                    (list
-                     eq?
-                     value
-                     0)
-                    )
+(define if
+  (macro (test args)
+        (cond ((null? (cdr args))
+               `(cond (,test ,(car args)))
+               )
+              (else
+               `(cond (,test ,(car args))
+                      (else ,(cadr args)))
+               )
+              )
+        )

   )
 
   )
 

+(if (> 3 2) 'yes)
+(if (> 3 2) 'yes 'no)
+(if (> 2 3) 'no 'yes)
+(if (> 2 3) 'no)
+
+                                       ; simple math operators
+
+(define zero? (macro (value rest) `(eq? ,value 0)))
+

 (zero? 1)
 (zero? 0)
 (zero? "hello")
 
 (zero? 1)
 (zero? 0)
 (zero? "hello")
 

-(define positive? (macro (value rest)
-                        (list
-                         >
-                         value
-                         0)
-                        )
-  )
+(define positive? (macro (value rest) `(> ,value 0)))

 
 (positive? 12)
 (positive? -12)
 
 
 (positive? 12)
 (positive? -12)
 

-(define negative? (macro (value rest)
-                        (list
-                         <
-                         value
-                         0)
-                        )
-  )
+(define negative? (macro (value rest) `(< ,value 0)))

 
 (negative? 12)
 (negative? -12)
 
 
 (negative? 12)
 (negative? -12)
 

-(defun abs (x) (cond ((>= x 0) x)
-                    (else (- x)))
-       )
+(define (abs x) (if (>= x 0) x (- x)))

 
 (abs 12)
 (abs -12)
 
 (abs 12)
 (abs -12)


@@ -145,48 +358,25 @@
 (min 1 2 3)
 (min 3 2 1)
 
 (min 1 2 3)
 (min 3 2 1)
 

-(defun even? (x) (zero? (% x 2)))
+(define (even? x) (zero? (% x 2)))

 
 (even? 2)
 (even? -2)
 (even? 3)
 (even? -1)
 
 
 (even? 2)
 (even? -2)
 (even? 3)
 (even? -1)
 

-(defun odd? (x) (not (even? x)))
+(define (odd? x) (not (even? x)))

 
 (odd? 2)
 (odd? -2)
 (odd? 3)
 (odd? -1)
 
 
 (odd? 2)
 (odd? -2)
 (odd? 3)
 (odd? -1)
 

-                                       ; (if <condition> <if-true>)
-                                       ; (if <condition> <if-true> <if-false)
-
-(define if (macro (test args)
-              (cond ((null? (cdr args))
-                     (list
-                      cond
-                      (list test (car args)))
-                     )
-                    (else
-                     (list
-                      cond
-                      (list test (car args))
-                      (list 'else (cadr args))
-                      )
-                     )
-                    )
-              )
-     )
-
-(if (> 3 2) 'yes)
-(if (> 3 2) 'yes 'no)
-(if (> 2 3) 'no 'yes)
-(if (> 2 3) 'no)

 
                                        ; define a set of local
 
                                        ; define a set of local

-                                       ; variables and then evaluate
-                                       ; a list of sexprs
+                                       ; variables all at once and
+                                       ; then evaluate a list of
+                                       ; sexprs

                                        ;
                                        ; (let (var-defines) sexprs)
                                        ;
                                        ;
                                        ; (let (var-defines) sexprs)
                                        ;


@@ -203,6 +393,71 @@
                                        ; (let ((x 1) (y)) (set! y (+ x 1)) y)
 
 (define let (macro (vars exprs)
                                        ; (let ((x 1) (y)) (set! y (+ x 1)) y)
 
 (define let (macro (vars exprs)

+               ((lambda (make-names make-vals)
+
+                                       ;
+                                       ; make the list of names in the let
+                                       ;
+
+                  (set! make-names (lambda (vars)
+                                     (cond ((not (null? vars))
+                                            (cons (car (car vars))
+                                                  (make-names (cdr vars))))
+                                           (else ())
+                                           )
+                                     )
+                        )
+
+                                       ; the parameters to the lambda is a list
+                                       ; of nils of the right length
+
+                  (set! make-vals (lambda (vars)
+                                    (cond ((not (null? vars))
+                                           (cons (cond ((null? (cdr (car vars))) ())
+                                                       (else
+                                                        (car (cdr (car vars))))
+                                                       )
+                                                 (make-vals (cdr vars))))
+                                          (else ())
+                                          )
+                                    )
+                        )
+                                       ; prepend the set operations
+                                       ; to the expressions
+
+                                       ; build the lambda.
+
+                  `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
+                  )
+                ()
+                ()
+                )
+               )
+     )
+                  
+
+(let ((x 1) (y)) (set! y 2) (+ x y))
+
+                                       ; define a set of local
+                                       ; variables one at a time and
+                                       ; then evaluate a list of
+                                       ; sexprs
+                                       ;
+                                       ; (let* (var-defines) sexprs)
+                                       ;
+                                       ; where var-defines are either
+                                       ;
+                                       ; (name value)
+                                       ;
+                                       ; or
+                                       ;
+                                       ; (name)
+                                       ;
+                                       ; e.g.
+                                       ;
+                                       ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
+
+(define let* (macro (vars exprs)

                ((lambda (make-names make-exprs make-nils)
 
                                        ;
                ((lambda (make-names make-exprs make-nils)
 
                                        ;


@@ -213,6 +468,7 @@
                                      (cond ((not (null? vars))
                                             (cons (car (car vars))
                                                   (make-names (cdr vars))))
                                      (cond ((not (null? vars))
                                             (cons (car (car vars))
                                                   (make-names (cdr vars))))

+                                           (else ())

                                            )
                                      )
                         )
                                            )
                                      )
                         )


@@ -235,7 +491,7 @@
                                              (make-exprs (cdr vars) exprs)
                                              )
                                             )
                                              (make-exprs (cdr vars) exprs)
                                              )
                                             )

-                                           (exprs)
+                                           (else exprs)

                                            )
                                      )
                         )
                                            )
                                      )
                         )


@@ -245,6 +501,7 @@
 
                   (set! make-nils (lambda (vars)
                                     (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
 
                   (set! make-nils (lambda (vars)
                                     (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))

+                                          (else ())

                                           )
                                     )
                         )
                                           )
                                     )
                         )


@@ -255,9 +512,7 @@
 
                                        ; build the lambda.
 
 
                                        ; build the lambda.
 

-                  (cons (cons 'lambda (cons (make-names vars) exprs))
-                        (make-nils vars)
-                        )
+                  `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars))

                   )
                 ()
                 ()
                   )
                 ()
                 ()


@@ -266,68 +521,17 @@
                )
      )
 
                )
      )
 

-(let ((x 1)) x)
-
-(define let* let)
-                                       ; boolean operators
-
-(define or (lexpr (l)
-              (let ((ret #f))
-                (while (not (null? l))
-                  (cond ((car l) (set! ret #t) (set! l ()))
-                        ((set! l (cdr l)))))
-                ret
-                )
-              )
-     )
-
-                                       ; execute to resolve macros
-
-(or #f #t)
-
-(define and (lexpr (l)
-              (let ((ret #t))
-                (while (not (null? l))
-                  (cond ((car l)
-                         (set! l (cdr l)))
-                        (#t
-                         (set! ret #f)
-                         (set! l ()))
-                        )
-                  )
-                ret
-                )
-              )
-     )
-
-                                       ; execute to resolve macros
+(let* ((x 1)) x)

 
 

-(and #t #f)
+(define when (macro (test l) `(cond (,test ,@l))))

 
 

+(when #t (write 'when))

 
 

-(define append (lexpr (args)
-                     (let ((append-list (lambda (a b)
-                                          (cond ((null? a) b)
-                                                (else (cons (car a) (append-list (cdr a) b)))
-                                                )
-                                          )
-                                        )
-                           (append-lists (lambda (lists)
-                                           (cond ((null? lists) lists)
-                                                 ((null? (cdr lists)) (car lists))
-                                                 (else (append-list (car lists) (append-lists (cdr lists))))
-                                                 )
-                                           )
-                                         )
-                           )
-                       (append-lists args)
-                       )
-                     )
-  )
+(define unless (macro (test l) `(cond ((not ,test) ,@l))))

 
 

-(append '(a b c) '(d e f) '(g h i))
+(unless #f (write 'unless))

 
 

-(defun reverse (list)
+(define (reverse list)

   (let ((result ()))
     (while (not (null? list))
       (set! result (cons (car list) result))
   (let ((result ()))
     (while (not (null? list))
       (set! result (cons (car list) result))


@@ -338,22 +542,20 @@
 
 (reverse '(1 2 3))
 
 
 (reverse '(1 2 3))
 

-(define list-tail
-  (lambda (x k)
-    (if (zero? k)
-       x
-      (list-tail (cdr x) (- k 1)))))
+(define (list-tail x k)
+  (if (zero? k)
+      x
+    (list-tail (cdr x) (- k 1)))))

 
 (list-tail '(1 2 3) 2)
 
 
 (list-tail '(1 2 3) 2)
 

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

 
 (list-ref '(1 2 3) 2)
 
 (list-ref '(1 2 3) 2)

-

     
                                        ; recursive equality
 
     
                                        ; recursive equality
 

-(defun equal? (a b)
+(define (equal? a b)

   (cond ((eq? a b) #t)
        ((and (pair? a) (pair? b))
         (and (equal? (car a) (car b))
   (cond ((eq? a b) #t)
        ((and (pair? a) (pair? b))
         (and (equal? (car a) (car b))


@@ -366,32 +568,41 @@
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
 
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
 

-(defun _member (obj list test?)
-  (if (null? list)
-      #f
-    (if (test? obj (car list))
-       list
-      (memq obj (cdr list)))))
+(define member (lexpr (obj list test?)
+                     (cond ((null? list)
+                            #f
+                            )
+                           (else
+                            (if (null? test?) (set! test? equal?) (set! test? (car test?)))
+                            (if (test? obj (car list))
+                                list
+                              (member obj (cdr list) test?))
+                            )
+                           )
+                     )
+  )
+
+(member '(2) '((1) (2) (3)))
+
+(member '(4) '((1) (2) (3)))

 
 

-(defun memq (obj list) (_member obj list eq?))
+(define (memq obj list) (member obj list eq?))

 
 (memq 2 '(1 2 3))
 
 (memq 4 '(1 2 3))
 
 
 (memq 2 '(1 2 3))
 
 (memq 4 '(1 2 3))
 

-(defun memv (obj list) (_member obj list eqv?))
+(memq '(2) '((1) (2) (3)))
+
+(define (memv obj list) (member obj list eqv?))

 
 (memv 2 '(1 2 3))
 
 (memv 4 '(1 2 3))
 
 
 (memv 2 '(1 2 3))
 
 (memv 4 '(1 2 3))
 

-(defun member (obj list) (_member obj list equal?))
+(memv '(2) '((1) (2) (3)))

 
 

-(member '(2) '((1) (2) (3)))
-
-(member '(4) '((1) (2) (3)))
-
-(defun _assoc (obj list test?)
+(define (_assoc obj list test?)

   (if (null? list)
       #f
     (if (test? obj (caar list))
   (if (null? list)
       #f
     (if (test? obj (caar list))


@@ -401,9 +612,9 @@
     )
   )
 
     )
   )
 

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

 
 (assq 'a '((a 1) (b 2) (c 3)))
 (assv 'b '((a 1) (b 2) (c 3)))
 
 (assq 'a '((a 1) (b 2) (c 3)))
 (assv 'b '((a 1) (b 2) (c 3)))


@@ -414,52 +625,52 @@
 (char? #\q)
 (char? "h")
 
 (char? #\q)
 (char? "h")
 

-(defun 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)
 (char-upper-case? #\B)
 (char-upper-case? #\0)
 (char-upper-case? #\space)
 

-(defun 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)
 (char-lower-case? #\B)
 (char-lower-case? #\0)
 (char-lower-case? #\space)
 

-(defun 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)
 (char-alphabetic? #\B)
 (char-alphabetic? #\0)
 (char-alphabetic? #\space)
 

-(defun 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)
 (char-numeric? #\B)
 (char-numeric? #\0)
 (char-numeric? #\space)
 

-(defun 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)
 (char-whitespace? #\B)
 (char-whitespace? #\0)
 (char-whitespace? #\space)
 

-(defun char->integer (c) c)
-(defun integer->char (c) char-integer)
+(define (char->integer c) c)
+(define (integer->char c) char-integer)

 
 

-(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
+(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)
 (char-upcase #\B)
 (char-upcase #\0)
 (char-upcase #\space)
 

-(defun 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 #\a)
 (char-downcase #\B)


@@ -472,17 +683,17 @@
 (apply cons '(a b))
 
 (define map (lexpr (proc lists)
 (apply cons '(a b))
 
 (define map (lexpr (proc lists)

-                  (let ((args (lambda (lists)
-                                (if (null? lists) ()
-                                  (cons (caar lists) (args (cdr lists))))))
-                        (next (lambda (lists)
-                                (if (null? lists) ()
-                                  (cons (cdr (car lists)) (next (cdr lists))))))
-                        (domap (lambda (lists)
-                                 (if (null? (car lists)) ()
-                                   (cons (apply proc (args lists)) (domap (next lists)))
-                                       )))
-                        )
+                  (let* ((args (lambda (lists)
+                                 (if (null? lists) ()
+                                   (cons (caar lists) (args (cdr lists))))))
+                         (next (lambda (lists)
+                                 (if (null? lists) ()
+                                   (cons (cdr (car lists)) (next (cdr lists))))))
+                         (domap (lambda (lists)
+                                  (if (null? (car lists)) ()
+                                    (cons (apply proc (args lists)) (domap (next lists)))
+                                    )))
+                         )

                     (domap lists))))
 
 (map cadr '((a b) (d e) (g h)))
                     (domap lists))))
 
 (map cadr '((a b) (d e) (g h)))


@@ -493,17 +704,17 @@
 
 (for-each display '("hello" " " "world" "\n"))
 
 
 (for-each display '("hello" " " "world" "\n"))
 

-(define -string-ml (lambda (strings)
+(define _string-ml (lambda (strings)

                             (if (null? strings) ()
                             (if (null? strings) ()

-                              (cons (string->list (car strings)) (-string-ml (cdr strings))))))
+                              (cons (string->list (car strings)) (_string-ml (cdr strings))))))

 
 (define string-map (lexpr (proc strings)
 
 (define string-map (lexpr (proc strings)

-                         (list->string (apply map proc (-string-ml strings))))))
+                         (list->string (apply map proc (_string-ml strings))))))

 
 

-(string-map 1+ "HAL")
+(string-map (lambda (x) (+ 1 x)) "HAL")

 
 (define string-for-each (lexpr (proc strings)
 
 (define string-for-each (lexpr (proc strings)

-                              (apply for-each proc (-string-ml strings))))
+                              (apply for-each proc (_string-ml strings))))

 
 (string-for-each write-char "IBM\n")
 
 
 (string-for-each write-char "IBM\n")
 


@@ -520,25 +731,64 @@
             '(54 0 37 -3 245 19))
    #t))
 
             '(54 0 37 -3 245 19))
    #t))
 

+
+                                       ; `q -> (quote q)
+                                       ; `(q) -> (append (quote (q)))
+                                       ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
+                                       ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
+
+
+
+`(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
+

 (define repeat (macro (count rest)
 (define repeat (macro (count rest)

-                       (list
-                        let
-                        (list
-                         (list '__count__ count))
-                        (append
-                         (list
-                          while
-                          (list
-                           <=
-                           0
-                           (list
-                            set!
-                            '__count__
-                            (list
-                             -
-                             '__count__
-                             1))))
-                         rest))))
+                      `(let ((__count__ ,count))
+                         (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest))))
+
+(repeat 2 (write 'hello))
+(repeat 3 (write 'goodbye))
+
+(define case (macro (test l)
+                   (let* ((_unarrow
+                                       ; construct the body of the
+                                       ; case, dealing with the
+                                       ; lambda version ( => lambda)
+                           
+                           (lambda (l)
+                             (cond ((null? l) l)
+                                   ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
+                                   (else l))))
+                          (_case (lambda (l)
+
+                                       ; Build the case elements, which is
+                                       ; simply a list of cond clauses
+
+                                   (cond ((null? l) ())
+
+                                       ; else case
+
+                                         ((eq? (caar l) 'else)
+                                          `((else ,@(_unarrow (cdr (car l))))))
+
+                                       ; regular case
+                                         
+                                         (else
+                                          (cons
+                                           `((eqv? ,(caar l) __key__)
+                                             ,@(_unarrow (cdr (car l))))
+                                           (_case (cdr l)))
+                                          )
+                                         ))))
+
+                                       ; now construct the overall
+                                       ; expression, using a lambda
+                                       ; to hold the computed value
+                                       ; of the test expression
+
+                     `((lambda (__key__)
+                         (cond ,@(_case l))) ,test))))
+
+(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))

 
 ;(define number->string (lexpr (arg opt)
 ;                            (let ((base (if (null? opt) 10 (car opt)))
 
 ;(define number->string (lexpr (arg opt)
 ;                            (let ((base (if (null? opt) 10 (car opt)))