* Added define-enumeration, which completes the (rnrs enums) library.

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]

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 ()
@@ -2198,6 +2239,7 @@
            ((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)

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]