conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

This commit is contained in:
Abdulaziz Ghuloum 2008-05-05 23:53:48 -04:00
parent 3bcc3249e5
commit b5fc5624ec
3 changed files with 53 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
scheme/ikarus.enumerations.ss
View File

@ -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)

2
scheme/last-revision
View File

@ -1 +1 @@
1468
1469

33
scheme/psyntax.expander.ss
View File

@ -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* ...)))]))))))])))