Fixed a bug in enum-set-universe not returning an enum type.

scheme/ikarus.enumerations.ss

@@ -31,15 +31,23 @@
     (opaque #t) (sealed #t)
     (nongenerative))
   
+  (define (remove-dups ls)
+    (cond
+      [(null? ls) '()]
+      [else (cons (car ls) (remq (car ls) (cdr ls)))]))
+
+
   (define (make-enumeration ls) 
     (unless (and (list? ls) (for-all symbol? ls))
       (die 'make-enumeration "not a list of symbols" ls))
-    (make-enum (gensym) ls ls))
+    (let ([u (remove-dups ls)])
+      (make-enum (gensym) u u)))
   
   (define (enum-set-universe x)
     (unless (enum? x) 
       (die 'enum-set-universe "not an enumeration" x))
-    (enum-univ x))
+    (let ([u (enum-univ x)])
+      (make-enum (enum-g x) u u)))
   
   (define (enum-set-indexer x)
     (unless (enum? x) 
@@ -58,7 +66,6 @@
   (define (enum-set-constructor x)
     (unless (enum? x) 
       (die 'enum-set-constructor "not an enumeration" x))
-    (let ([idx (enum-set-indexer x)])
     (lambda (ls) 
       (unless (and (list? ls) (for-all symbol? ls))
         (die 'enum-set-constructor "not a list of symbols" ls))
@@ -68,15 +75,17 @@
             (die 'enum-set-constructor "not in the universe" s x)))
         ls)
       (make-enum (enum-g x) (enum-univ x) 
-          (map car
-            (list-sort (lambda (a b) (< (cdr a) (cdr b)))
-              (map (lambda (x) (cons x (idx x)))
-                   ls)))))))
+        (remove-dups ls))))
     
   (define (enum-set->list x)
     (unless (enum? x) 
       (die 'enum-set->list "not an enumeration" x))
-    (map values (enum-values x)))
+    (let ([idx (enum-set-indexer x)]
+          [ls (enum-values x)])
+      (map car
+        (list-sort (lambda (a b) (< (cdr a) (cdr b)))
+          (map (lambda (x) (cons x (idx x)))
+               ls)))))
   
   (define (enum-set-member? s x) 
     (if (enum? x)

scheme/last-revision

@@ -1 +1 @@
-1468
+1469

scheme/psyntax.expander.ss

@@ -1367,14 +1367,25 @@
         (or (null? x) 
             (and (not (memq (car x) (cdr x)))
                  (set? (cdr x)))))
+      (define (remove-dups ls)
+        (cond
+          [(null? ls) '()]
+          [else 
+           (cons (car ls) 
+              (remove-dups (remq (car ls) (cdr ls))))]))
       (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"))
+         (let ([name* (remove-dups (syntax->datum id*))] [mk (gensym)]) 
            (bless 
              `(begin
+                ;;; can be constructed at compile time
+                ;;; but ....  it's not worth it.
+                ;;; also, generativity of defined enum types
+                ;;; is completely unspecified, making them just
+                ;;; more useless than they really are.
+                ;;; eventually, I'll make them all compile-time
+                ;;; generative just to piss some known people off.
                 (define ,mk 
                   (enum-set-constructor 
                     (make-enumeration ',name*)))
@@ -1385,9 +1396,9 @@
                        (identifier? #'n)
                        (if (memq (syntax->datum #'n) ',name*) 
                            #''n
-                           (syntax-error x
+                           (syntax-violation ',name
                               "not a member of set"
-                              ',name*))])))
+                              x #'n))])))
                 (define-syntax ,maker
                   (lambda (x)
                     (syntax-case x ()
@@ -1396,9 +1407,17 @@
                          (for-each
                            (lambda (n) 
                               (unless (identifier? n) 
-                                (syntax-error x "non-identifier argument"))
+                                (syntax-violation
+                                  ',maker 
+                                  "non-identifier argument"
+                                  x
+                                  n))
                               (unless (memq (syntax->datum n) ',name*)
-                                (syntax-error n "not a member of set")))
+                                (syntax-violation
+                                  ',maker
+                                  "not a member of set"
+                                  x
+                                  n)))
                            #'(n* ...))
                          #'(,mk '(n* ...)))]))))))])))