Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Define define-condition-type/constructor with syntax-rules

Browse source
This commit is contained in:
Daphne Preston-Kendal 2024-10-27 10:35:52 +01:00
parent 3777c1b935
commit 76f35bc733
1 changed files with 13 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
lib/srfi/35/internal.scm
View file

@ -129,43 +129,19 @@
c ct)))))
(define-syntax define-condition-type/constructor
(er-macro-transformer
(lambda (expr rename compare)
(let* ((name (list-ref expr 1))
(parent (list-ref expr 2))
(constructor (list-ref expr 3))
(predicate (list-ref expr 4))
(field-specs (drop expr 5))
(field-names (map first field-specs))
(field-accessors (map second field-specs)))
(define _begin (rename 'begin))
(define _define (rename 'define))
(define _make-condition-type (rename 'make-condition-type))
(define _compound-condition? (rename 'compound-condition?))
(define _condition-predicate (rename 'condition-predicate))
(define _condition-accessor (rename 'condition-accessor))
(define _rtd-constructor (rename 'rtd-constructor))
(define _rtd-accessor (rename 'rtd-accessor))
(define _and (rename 'and))
(define _if (rename 'if))
(define _ct (rename 'ct))
(define _x (rename 'x))
`(,_begin
(,_define ,_ct
(,_make-condition-type ',name
,parent
',field-names))
(,_define ,name ,_ct)
(,_define ,constructor (,_rtd-constructor ,_ct))
(,_define ,predicate (,_condition-predicate ,_ct))
,@(map
(lambda (field-name field-accessor)
`(,_define ,field-accessor
(,_condition-accessor
,_ct
(,_rtd-accessor ,_ct ',field-name))))
field-names
field-accessors))))))
(syntax-rules ()
((_ name parent constructor predicate
(field-name field-accessor) ...)
(begin
(define ct (make-condition-type 'name
parent
'(field-name ...)))
(define name ct)
(define constructor (rtd-constructor ct))
(define predicate (condition-predicate ct))
(define field-accessor
(condition-accessor ct
(rtd-accessor ct 'field-name))) ...))))
(define-syntax define-condition-type
(syntax-rules ()