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))))) c ct)))))
(define-syntax define-condition-type/constructor (define-syntax define-condition-type/constructor
(er-macro-transformer (syntax-rules ()
(lambda (expr rename compare) ((_ name parent constructor predicate
(let* ((name (list-ref expr 1)) (field-name field-accessor) ...)
(parent (list-ref expr 2)) (begin
(constructor (list-ref expr 3)) (define ct (make-condition-type 'name
(predicate (list-ref expr 4)) parent
(field-specs (drop expr 5)) '(field-name ...)))
(field-names (map first field-specs)) (define name ct)
(field-accessors (map second field-specs))) (define constructor (rtd-constructor ct))
(define _begin (rename 'begin)) (define predicate (condition-predicate ct))
(define _define (rename 'define)) (define field-accessor
(define _make-condition-type (rename 'make-condition-type)) (condition-accessor ct
(define _compound-condition? (rename 'compound-condition?)) (rtd-accessor ct 'field-name))) ...))))
(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))))))
(define-syntax define-condition-type (define-syntax define-condition-type
(syntax-rules () (syntax-rules ()