Support => in cond.

* module/mes/base-0.mes (cond): Support =>.
* module/mes/rea-0.mes (cond): Update.
* NEWS: Update.

diff --git a/NEWS b/NEWS
index 36449e0f16563bdaf1617355d3d52c474ed2c9e7..4b21966295d516f826838d2800d76720a259d71d 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -18,6 +18,7 @@ The C-reader needs only support reading of words and lists
 block-comments are all handled by the Scheme reader later.
 ** Language
 *** Keywords are supported.
+*** Cond now supports =>.
 * Changes in 0.3 since 0.2
 ** Core
 *** Number-based rather than pointer-based cells.

diff --git a/mes.c b/mes.c
index fdb66ca5af1f81a104e73cc49336edb1c858ac46..1ca53e0777034e2aa7dae6135161c213c04fc499 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -84,6 +84,7 @@ scm scm_nil = {SPECIAL, "()"};
 scm scm_f = {SPECIAL, "#f"};
 scm scm_t = {SPECIAL, "#t"};
 scm scm_dot = {SPECIAL, "."};
+scm scm_arrow = {SPECIAL, "=>"};
 scm scm_undefined = {SPECIAL, "*undefined*"};
 scm scm_unspecified = {SPECIAL, "*unspecified*"};
 scm scm_closure = {SPECIAL, "*closure*"};

diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes
index bc5c110325078a989a45d11f64686c09ea64bfec..1cf396a339128a845d6274f4f4340fb8eb8d5ac9 100644 (file)
--- a/module/mes/base-0.mes
+++ b/module/mes/base-0.mes
@@ -60,18 +60,20 @@
       (apply f (apply cons* (cons h t)))))
 
 (define-macro (cond . clauses)
-  (list 'if (null? clauses) *unspecified*
-        (if (null? (cdr clauses))
-           (list 'if (car (car clauses))
-                 (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
-                 *unspecified*)
-           (if (eq? (car (cadr clauses)) 'else)
-               (list 'if (car (car clauses))
-                   (list (cons 'lambda (cons '() (car clauses))))
-                   (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
-               (list 'if (car (car clauses))
-                   (list (cons 'lambda (cons '() (car clauses))))
-                   (cons 'cond (cdr clauses)))))))
+  (list 'if (pair? clauses)
+        (list (cons
+               'lambda
+               (cons
+                '(test)
+                (list (list 'if 'test
+                            (if (pair? (cdar clauses))
+                                (if (eq? (cadar clauses) '=>)
+                                    (append2 (cddar clauses) '(test))
+                                    (list (cons 'lambda (cons '() (car clauses)))))
+                                (list (cons 'lambda (cons '() (car clauses)))))
+                            (if (pair? (cdr clauses))
+                                (cons 'cond (cdr clauses)))))))
+              (car (car clauses)))))
 
 (define else #t)
 

diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes
index dddfaa79190c62af2012d9dfd9c8ff1945ddda79..ea854e16d378011c50a5db61461e7a52c8f0b10f 100644 (file)
--- a/module/mes/read-0.mes
+++ b/module/mes/read-0.mes
@@ -54,19 +54,16 @@
     (helper (read)))
 
   (define-macro (cond . clauses)
-    (list (quote if) (null? clauses) *unspecified*
-          (if (null? (cdr clauses))
-              (list (quote if) (car (car clauses))
-                    (list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses))))))
-                    *unspecified*)
-              (if (eq? (car (cadr clauses)) (quote else))
-                  (list (quote if) (car (car clauses))
-                        (list (cons (quote lambda) (cons (list) (car clauses))))
-                        (list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses)))))))
-                  (list (quote if) (car (car clauses))
-                        (list (cons (quote lambda) (cons (list) (car clauses))))
-                        (cons (quote cond) (cdr clauses)))))))
-
+    (list 'if (pair? clauses)
+          (list 'if (car (car clauses))
+                (if (pair? (cdar clauses))
+                    (if (eq? (cadar clauses) '=>)
+                        (append2 (cddar clauses) (list (caar clauses)))
+                        (list (cons 'lambda (cons '() (car clauses)))))
+                    (list (cons 'lambda (cons '() (car clauses)))))
+              (if (pair? (cdr clauses))
+                  (cons 'cond (cdr clauses))))))
+  
   (define (eat-whitespace)
     (cond
      ((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
@@ -130,7 +127,7 @@
                            (read-byte)
                            (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
                                  (cons (read-word (read-byte) w a) (list))))
-                          (else
+                          (#t
                            (cons (lookup (symbol->list (quote unsyntax)) a)
                                  (cons (read-word (read-byte) w a) (list))))))
                    ((eq? (peek-byte) 39) (read-byte)
@@ -139,7 +136,7 @@
                    ((eq? (peek-byte) 96) (read-byte)
                     (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
                           (cons (read-word (read-byte) w a) (list))))
-                   (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
+                   (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
       ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
                                       (cons (read-word (read-byte) w a) (list)))
                       (begin (unread-byte c) (lookup w a))))
@@ -153,11 +150,11 @@
                                                 (cons
                                                  (lookup (symbol->list (quote unquote-splicing)) a)
                                                  (cons (read-word (read-byte) w a) (list)))))
-                   (else  (cons (lookup-char c a) (cons (read-word (read-byte) w a)
+                   (#t (cons (lookup-char c a) (cons (read-word (read-byte) w a)
                                                         (list))))))
       ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
-      (else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
+      (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
 
   ((lambda (p)
      ;;(display (quote scheme-program=)) (display p) (newline)

diff --git a/tests/base.test b/tests/base.test
index 8670c3702cdb5937ba7e9ab98f20a3664f6852d1..5f23e0af3566bb839335d90d26593337b116eb7f 100755 (executable)
--- a/tests/base.test
+++ b/tests/base.test
@@ -52,8 +52,14 @@ exit $?
       (pass-if "cond" (seq? (cond (#t)) #t))
       (pass-if "cond 2" (seq? (cond (#f)) *unspecified*))
       (pass-if "cond 3" (seq? (cond (#t 0)) 0))
-      (pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0)))
-    )
+      (pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0))
+      (pass-if-equal "cond => "
+          0 (let ((lst '(0 1 2)))
+              (define (next)
+                (let ((r (car lst)))
+                  (set! lst (cdr lst))
+                  r))
+              (cond ((next) => identity))))))
 
 (pass-if "and" (seq? (and 1) 1))
 (pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))