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]