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

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

This commit is contained in:
Abdulaziz Ghuloum 2007-10-27 11:40:40 -04:00
parent 79a38bc54b
commit 988c13e123
3 changed files with 68 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
scheme/makefile.ss
View File

@ -166,6 +166,7 @@
[nongenerative (macro . nongenerative)] [nongenerative (macro . nongenerative)]
[parent-rtd (macro . parent-rtd)] [parent-rtd (macro . parent-rtd)]
[define-record-type (macro . define-record-type)] [define-record-type (macro . define-record-type)]
[define-enumeration (macro . define-enumeration)]
[define-condition-type (macro . define-condition-type)] [define-condition-type (macro . define-condition-type)]
[&condition ($core-rtd . (&condition-rtd &condition-rcd))] [&condition ($core-rtd . (&condition-rtd &condition-rcd))]
[&message ($core-rtd . (&message-rtd &message-rcd))] [&message ($core-rtd . (&message-rtd &message-rcd))]
@ -967,7 +968,7 @@
[do i r ct se ne] [do i r ct se ne]
[unless i r ct] [unless i r ct]
[when i r ct] [when i r ct]
[define-enumeration r en] [define-enumeration i r en]
[enum-set->list i r en] [enum-set->list i r en]
[enum-set-complement i r en] [enum-set-complement i r en]
[enum-set-constructor i r en] [enum-set-constructor i r en]

86
scheme/psyntax.expander.ss
View File

@ -1076,6 +1076,47 @@
,(gen-clauses con outerk clause*)) ,(gen-clauses con outerk clause*))
(lambda () #f ,b ,@b*))))))))]))) (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 (define time-macro
(lambda (stx) (lambda (stx)
(syntax-match stx () (syntax-match stx ()
@ -2179,28 +2220,29 @@
((procedure? x) x) ((procedure? x) x)
((symbol? x) ((symbol? x)
(case x (case x
((define-record-type) define-record-type-macro) ((define-record-type) define-record-type-macro)
((define-struct) define-struct-macro) ((define-struct) define-struct-macro)
((include) include-macro) ((include) include-macro)
((cond) cond-macro) ((cond) cond-macro)
((let) let-macro) ((let) let-macro)
((do) do-macro) ((do) do-macro)
((or) or-macro) ((or) or-macro)
((and) and-macro) ((and) and-macro)
((let*) let*-macro) ((let*) let*-macro)
((syntax-rules) syntax-rules-macro) ((syntax-rules) syntax-rules-macro)
((quasiquote) quasiquote-macro) ((quasiquote) quasiquote-macro)
((quasisyntax) quasisyntax-macro) ((quasisyntax) quasisyntax-macro)
((with-syntax) with-syntax-macro) ((with-syntax) with-syntax-macro)
((identifier-syntax) identifier-syntax-macro) ((identifier-syntax) identifier-syntax-macro)
((time) time-macro) ((time) time-macro)
((delay) delay-macro) ((delay) delay-macro)
((assert) assert-macro) ((assert) assert-macro)
((endianness) endianness-macro) ((endianness) endianness-macro)
((guard) guard-macro) ((guard) guard-macro)
((trace-lambda) trace-lambda-macro) ((define-enumeration) define-enumeration-macro)
((trace-define) trace-define-macro) ((trace-lambda) trace-lambda-macro)
((define-condition-type) define-condition-type-macro) ((trace-define) trace-define-macro)
((define-condition-type) define-condition-type-macro)
((eol-style) ((eol-style)
(lambda (x) (lambda (x)
(symbol-macro x '(none lf cr crlf nel crnel ls)))) (symbol-macro x '(none lf cr crlf nel crnel ls))))

4
scheme/todo-r6rs.ss
View File

@ -38,6 +38,7 @@
[rp (rnrs records procedural (6))] [rp (rnrs records procedural (6))]
[rs (rnrs records syntactic (6))] [rs (rnrs records syntactic (6))]
[co (rnrs conditions (6))] [co (rnrs conditions (6))]
[en (rnrs enums (6))]
[is (rnrs io simple (6))] [is (rnrs io simple (6))]
[ba (rnrs base (6))] [ba (rnrs base (6))]
[bv (rnrs bytevectors (6))] [bv (rnrs bytevectors (6))]
@ -47,7 +48,6 @@
[fl (rnrs arithmetic flonums (6))] [fl (rnrs arithmetic flonums (6))]
[ht (rnrs hashtables (6))] [ht (rnrs hashtables (6))]
[ip (rnrs io ports (6))] [ip (rnrs io ports (6))]
[en (rnrs enums (6))]
)) ))
(define status-names (define status-names
@ -486,7 +486,7 @@
[unless C ct] [unless C ct]
[when C ct] [when C ct]
;;; ;;;
[define-enumeration D en] [define-enumeration C en]
[enum-set->list C en] [enum-set->list C en]
[enum-set-complement C en] [enum-set-complement C en]
[enum-set-constructor C en] [enum-set-constructor C en]