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

* Added define-condition-type macro.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-23 17:53:43 -04:00
parent 2684b53323
commit 239141717f
4 changed files with 39 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

1
scheme/makefile.ss
View File

@ -148,6 +148,7 @@
[nongenerative (macro . nongenerative)]
[parent-rtd (macro . parent-rtd)]
[define-record-type (macro . define-record-type)]
[define-condition-type (macro . define-condition-type)]
[&condition ($core-rtd . (&condition-rtd &condition-rcd))]
[&message ($core-rtd . (&message-rtd &message-rcd))]
[&warning ($core-rtd . (&warning-rtd &warning-rcd ))]

38
scheme/psyntax.expander.ss
View File

@ -1579,6 +1579,41 @@
[(ctxt namespec clause* ...)
(do-define-record ctxt namespec clause*)])))
(define define-condition-type-macro
(lambda (x)
(define (mkname name suffix)
(datum->syntax name
(string->symbol
(string-append
(symbol->string (syntax->datum name))
suffix))))
(syntax-match x ()
[(ctxt name super constructor predicate (field* accessor*) ...)
(and (id? name)
(id? super)
(id? constructor)
(id? predicate)
(for-all id? field*)
(for-all id? accessor*))
(let ([aux-accessor* (map (lambda (x) (gensym)) accessor*)])
(bless
`(begin
(define-record-type (,name ,constructor ,(gensym))
(parent ,super)
(fields ,@(map (lambda (field aux)
`(immutable ,field ,aux))
field* aux-accessor*))
(nongenerative)
(sealed #f) (opaque #f))
(define ,predicate (condition-predicate
(record-type-descriptor ,name)))
,@(map
(lambda (accessor aux)
`(define ,accessor
(condition-accessor
(record-type-descriptor ,name) ,aux)))
accessor* aux-accessor*))))])))
(define incorrect-usage-macro
(lambda (e) (stx-error e "incorrect usage of auxilary keyword")))
@ -2117,7 +2152,8 @@
((endianness) endianness-macro)
((trace-lambda) trace-lambda-macro)
((trace-define) trace-define-macro)
((eol-style)
((define-condition-type) define-condition-type-macro)
((eol-style)
(lambda (x)
(symbol-macro x '(none lf cr crlf nel crnel ls))))
((error-handling-mode)

2
scheme/todo-r6rs.ss
View File

@ -423,7 +423,7 @@
[condition-message C co]
[condition-predicate C co]
[condition-who C co]
[define-condition-type S co]
[define-condition-type C co]
[&error C co]
[error? C co]
[&implementation-restriction C co]