diff --git a/scheme/ikarus.enumerations.ss b/scheme/ikarus.enumerations.ss index ce02347..a7189de 100644 --- a/scheme/ikarus.enumerations.ss +++ b/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,25 +66,26 @@ (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)) - (for-each - (lambda (s) - (unless (memq s (enum-univ x)) - (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))))))) + (lambda (ls) + (unless (and (list? ls) (for-all symbol? ls)) + (die 'enum-set-constructor "not a list of symbols" ls)) + (for-each + (lambda (s) + (unless (memq s (enum-univ x)) + (die 'enum-set-constructor "not in the universe" s x))) + ls) + (make-enum (enum-g x) (enum-univ x) + (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) diff --git a/scheme/last-revision b/scheme/last-revision index 30c63a2..6d36565 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1468 +1469 diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index d5cb97c..4f4051d 100644 --- a/scheme/psyntax.expander.ss +++ b/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* ...)))]))))))])))