From 988c13e1233c581ca816cc8f1a37bc0d519e927b Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 27 Oct 2007 11:40:40 -0400
Subject: [PATCH] * Added define-enumeration, which completes the (rnrs enums)
 library.

---
 scheme/makefile.ss         |  3 +-
 scheme/psyntax.expander.ss | 86 ++++++++++++++++++++++++++++----------
 scheme/todo-r6rs.ss        |  4 +-
 3 files changed, 68 insertions(+), 25 deletions(-)

diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 34f82bf..69e08dd 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -166,6 +166,7 @@
     [nongenerative       (macro . nongenerative)]
     [parent-rtd          (macro . parent-rtd)]
     [define-record-type  (macro . define-record-type)]
+    [define-enumeration  (macro . define-enumeration)]
     [define-condition-type  (macro . define-condition-type)]
     [&condition                ($core-rtd . (&condition-rtd &condition-rcd))]
     [&message                  ($core-rtd . (&message-rtd &message-rcd))]
@@ -967,7 +968,7 @@
     [do                                          i r ct se ne]
     [unless                                      i r ct]
     [when                                        i r ct]
-    [define-enumeration                          r en]
+    [define-enumeration                          i r en]
     [enum-set->list                              i r en]
     [enum-set-complement                         i r en]
     [enum-set-constructor                        i r en]
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 8093f28..44581f2 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -1076,6 +1076,47 @@
                          ,(gen-clauses con outerk clause*))
                        (lambda () #f ,b ,@b*))))))))])))
 
+  (define define-enumeration-macro
+    (lambda (stx) 
+      (define (set? x)
+        (or (null? x) 
+            (and (not (memq (car x) (cdr x)))
+                 (set? (cdr x)))))
+      (syntax-match stx ()
+        [(_ name (id* ...) maker) 
+         (and (id? name) (id? maker) (for-all id? id*))
+         (let ([name* (syntax->datum id*)] [mk (gensym)]) 
+           (unless (set? name*) 
+             (stx-error stx "duplicate names in enumeration set"))
+           (bless 
+             `(begin
+                (define ,mk 
+                  (enum-set-constructor 
+                    (make-enumeration ',name*)))
+                (define-syntax ,name 
+                  (lambda (x) 
+                    (syntax-case x () 
+                      [(_ n)
+                       (identifier? #'n)
+                       (if (memq (syntax->datum #'n) ',name*) 
+                           #''n
+                           (syntax-error x
+                              "not a member of set"
+                              ',name*))])))
+                (define-syntax ,maker
+                  (lambda (x)
+                    (syntax-case x ()
+                      [(_ n* ...)
+                       (begin
+                         (for-each
+                           (lambda (n) 
+                              (unless (identifier? n) 
+                                (syntax-error x "non-identifier argument"))
+                              (unless (memq (syntax->datum n) ',name*)
+                                (syntax-error n "not a member of set")))
+                           #'(n* ...))
+                         #'(,mk '(n* ...)))]))))))])))
+
   (define time-macro
     (lambda (stx)
       (syntax-match stx ()
@@ -2179,28 +2220,29 @@
         ((procedure? x) x)
         ((symbol? x)
          (case x
-           ((define-record-type) define-record-type-macro)
-           ((define-struct)     define-struct-macro)
-           ((include)           include-macro)
-           ((cond)              cond-macro)
-           ((let)               let-macro)
-           ((do)                do-macro)
-           ((or)                or-macro)
-           ((and)               and-macro)
-           ((let*)              let*-macro)
-           ((syntax-rules)      syntax-rules-macro)
-           ((quasiquote)        quasiquote-macro)
-           ((quasisyntax)       quasisyntax-macro)
-           ((with-syntax)       with-syntax-macro)
-           ((identifier-syntax) identifier-syntax-macro)
-           ((time)              time-macro)
-           ((delay)             delay-macro)
-           ((assert)            assert-macro)
-           ((endianness)        endianness-macro)
-           ((guard)             guard-macro)
-           ((trace-lambda)      trace-lambda-macro)
-           ((trace-define)      trace-define-macro)
-           ((define-condition-type)      define-condition-type-macro)
+           ((define-record-type)    define-record-type-macro)
+           ((define-struct)         define-struct-macro)
+           ((include)               include-macro)
+           ((cond)                  cond-macro)
+           ((let)                   let-macro)
+           ((do)                    do-macro)
+           ((or)                    or-macro)
+           ((and)                   and-macro)
+           ((let*)                  let*-macro)
+           ((syntax-rules)          syntax-rules-macro)
+           ((quasiquote)            quasiquote-macro)
+           ((quasisyntax)           quasisyntax-macro)
+           ((with-syntax)           with-syntax-macro)
+           ((identifier-syntax)     identifier-syntax-macro)
+           ((time)                  time-macro)
+           ((delay)                 delay-macro)
+           ((assert)                assert-macro)
+           ((endianness)            endianness-macro)
+           ((guard)                 guard-macro)
+           ((define-enumeration)    define-enumeration-macro)
+           ((trace-lambda)          trace-lambda-macro)
+           ((trace-define)          trace-define-macro)
+           ((define-condition-type) define-condition-type-macro)
            ((eol-style)
             (lambda (x) 
               (symbol-macro x '(none lf cr crlf nel crnel ls))))
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index b7fcf2e..657a80a 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -38,6 +38,7 @@
     [rp (rnrs records procedural (6))]
     [rs (rnrs records syntactic (6))]
     [co (rnrs conditions (6))]
+    [en (rnrs enums (6))]
     [is (rnrs io simple (6))]
     [ba (rnrs base (6))]
     [bv (rnrs bytevectors (6))]
@@ -47,7 +48,6 @@
     [fl (rnrs arithmetic flonums (6))]
     [ht (rnrs hashtables (6))]
     [ip (rnrs io ports (6))]
-    [en (rnrs enums (6))]
     ))
 
 (define status-names
@@ -486,7 +486,7 @@
     [unless                                     C ct]
     [when                                       C ct]
     ;;;
-    [define-enumeration                         D en]
+    [define-enumeration                         C en]
     [enum-set->list                             C en]
     [enum-set-complement                        C en]
     [enum-set-constructor                       C en]