[pypy-commit] lang-scheme default: Stubbing of case, basic tests work

[boemmels]

Author: Juergen Boemmels <boemmels at web.de>
Branch: 
Changeset: r37:046b82d2ef4c
Date: 2012-01-09 22:07 +0100
http://bitbucket.org/pypy/lang-scheme/changeset/046b82d2ef4c/

Log:	Stubbing of case, basic tests work

diff --git a/scheme/r5rs_derived_expr.ss b/scheme/r5rs_derived_expr.ss
--- a/scheme/r5rs_derived_expr.ss
+++ b/scheme/r5rs_derived_expr.ss
@@ -39,3 +39,18 @@
      (let ((x test1))
        (if x x (or test2 ...))))))
 
+(define-syntax case
+  (syntax-rules (else)
+;;; XXX this check does not work yet
+;    ((case (key ...) clauses ...)
+;     (let ((atom-key (key ...)))
+;       (case atom-key clauses ...)))
+    ((case key (else expr1 expr2 ...))
+     (begin expr1 expr2 ...))
+    ((case key ((atoms ...) expr1 expr2 ...))
+     (if (memv key '(atoms ...))
+         (begin expr1 expr2 ...)))
+    ((case key ((atoms ...) expr1 expr2 ...) clause2 clause3 ...)
+     (if (memv key '(atoms ...))
+         (begin expr1 expr2 ...)
+         (case key clause2 clause3 ...)))))
diff --git a/scheme/test/test_eval.py b/scheme/test/test_eval.py
--- a/scheme/test/test_eval.py
+++ b/scheme/test/test_eval.py
@@ -1005,3 +1005,20 @@
     w_res = eval_noctx("""(cddddr '((((a b) c d) (e f) g h)
                                     ((i j) k l) (m n) o p))""")
     assert w_res.equal(parse_("(p)"))
+
+def test_case():
+    w_res = eval_noctx("""
+         (case (* 2 3)
+           ((2 3 5 7) 'prime)
+           ((1 4 6 8 9) 'composite))
+           """)
+    assert w_res.eq(symbol("composite"))
+
+    w_res = eval_noctx("""
+         (case (car '(c d))
+           ((a e i o u) 'vowel)
+           ((w y) 'semivowel)
+           (else 'consonant))
+           """)
+    assert w_res.eq(symbol("consonant"))
+