#lang scheme/base
(define-syntax %syntax-error (syntax-rules () ((_) #f)))
(define-syntax define-record-type/write
(syntax-rules ()
((_ NAME
CONSTRUCTOR-SPEC
PREDICATE-NAME
WRITE-PROC
FIELD-SPEC ...)
(%define-record-type/write:do-fields (FIELD-SPEC ...)
() () () () CONSTRUCTOR-SPEC
struct-accessor
struct-mutator
NAME
PREDICATE-NAME
WRITE-PROC))))
(define-syntax %define-record-type/write:do-fields
(syntax-rules ()
((_ ((FIELD-TAG ACCESSOR-NAME MUTATOR-NAME) FIELD-SPEC-1 ...)
FIELD-TAGS
(FIELD-ONE ...)
(ACC-MUT-NAME ...)
(ACC-MUT-VAL ...)
CONSTRUCTOR-SPEC
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%define-record-type/write:do-fields
((FIELD-TAG ACCESSOR-NAME) FIELD-SPEC-1 ...)
FIELD-TAGS
(FIELD-ONE ...)
(ACC-MUT-NAME ... MUTATOR-NAME)
(ACC-MUT-VAL ...
(let ((MUTATOR-NAME
(lambda (x v)
(STRUCT-MUTATOR-NAME x (+ FIELD-ONE ...) v))))
MUTATOR-NAME))
CONSTRUCTOR-SPEC
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC))
((_ ((FIELD-TAG ACCESSOR-NAME) FIELD-SPEC-1 ...)
(FIELD-TAG-0 ...)
(FIELD-ONE ...)
(ACC-MUT-NAME ...)
(ACC-MUT-VAL ...)
CONSTRUCTOR-SPEC
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%define-record-type/write:do-fields
(FIELD-SPEC-1 ...)
(FIELD-TAG-0 ... FIELD-TAG)
(1 FIELD-ONE ...)
(ACC-MUT-NAME ... ACCESSOR-NAME)
(ACC-MUT-VAL ...
(let ((ACCESSOR-NAME
(lambda (x)
(STRUCT-ACCESSOR-NAME x (+ FIELD-ONE ...)))))
ACCESSOR-NAME))
CONSTRUCTOR-SPEC
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC))
((_ () FIELD-TAGS
FIELD-ONES
ACC-MUT-NAMES
ACC-MUT-VALS
(CONSTRUCTOR-NAME CONSTRUCTOR-TAG-0 CONSTRUCTOR-TAG-1 ...)
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%define-record-type/write:do-constructor
(CONSTRUCTOR-TAG-0 CONSTRUCTOR-TAG-1 ...)
FIELD-TAGS
() () (CONSTRUCTOR-TAG-0 CONSTRUCTOR-TAG-1 ...)
FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC))
((_ () X ...)
(%syntax-error "invalid constructor spec"))))
(define-syntax %define-record-type/write:do-constructor
(syntax-rules ()
((_ (CONSTRUCTOR-TAG CONSTRUCTOR-TAG-1 ...)
(FIELD-TAG FIELD-TAG-1 ...)
(INIT-ONE ...)
AUTO-ONES
ORIG-CONSTRUCTOR-TAGS
ORIG-FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%define-record-type/write:do-constructor
(CONSTRUCTOR-TAG-1 ...)
(FIELD-TAG-1 ...)
(1 INIT-ONE ...)
AUTO-ONES
ORIG-CONSTRUCTOR-TAGS
ORIG-FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC))
((_ (CONSTRUCTOR-TAG CONSTRUCTOR-TAG-1 ...)
()
INIT-ONES
AUTO-ONES
ORIG-CONSTRUCTOR-TAGS
ORIG-FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%syntax-error "too many field tags in constructor" CONSTRUCTOR-TAG))
((_ () (FIELD-TAG FIELD-TAG-1 ...)
INIT-ONES
(AUTO-ONE ...)
ORIG-CONSTRUCTOR-TAGS
ORIG-FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%define-record-type/write:do-constructor
() (FIELD-TAG-1 ...)
INIT-ONES
(1 AUTO-ONE ...)
ORIG-CONSTRUCTOR-TAGS
ORIG-FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC))
((_ () () INIT-ONES
AUTO-ONES
ORIG-CONSTRUCTOR-TAGS
ORIG-FIELD-TAGS
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(%define-record-type/write:last
ORIG-CONSTRUCTOR-TAGS ORIG-FIELD-TAGS INIT-ONES
AUTO-ONES
ACC-MUT-NAMES
ACC-MUT-VALS
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC))))
(define-syntax %define-record-type/write:last
(syntax-rules ()
((_ (CONSTRUCTOR-TAG ...)
(FIELD-TAG ...)
(INIT-ONE ...)
(AUTO-ONE ...)
(ACC-MUT-NAME ...)
(ACC-MUT-VAL ...)
CONSTRUCTOR-NAME
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME
NAME
PREDICATE-NAME
WRITE-PROC)
(define-values (NAME
CONSTRUCTOR-NAME
PREDICATE-NAME
ACC-MUT-NAME ...)
(let-values (((type
constructor
predicate
STRUCT-ACCESSOR-NAME
STRUCT-MUTATOR-NAME)
(make-struct-type (quote NAME) #f (+ INIT-ONE ...) (+ AUTO-ONE ...) #f (if WRITE-PROC
(list (cons prop:custom-write
WRITE-PROC))
'()))))
(values type
(begin (%check-constructor 'define-struct-type/write
constructor
(quote (CONSTRUCTOR-TAG ...))
(quote (FIELD-TAG ...)))
(let ((CONSTRUCTOR-NAME
(lambda (CONSTRUCTOR-TAG ...)
(constructor CONSTRUCTOR-TAG ...))))
CONSTRUCTOR-NAME))
(let ((PREDICATE-NAME (lambda (x) (predicate x))))
PREDICATE-NAME)
ACC-MUT-VAL ...))))))
(define (%check-constructor error-sym struct-constructor c-tags f-tags)
(let loop ((c-tags c-tags)
(f-tags f-tags)
(seen-tags '()))
(if (null? c-tags)
struct-constructor
(if (null? f-tags)
(error error-sym
"internal error: too many constructor tags")
(let ((ct (car c-tags))
(ft (car f-tags)))
(if (memq ct seen-tags)
(error error-sym
"field tag occurs multiply in constructor spec: ~S"
ct)
(if (eq? ct ft)
(loop (cdr c-tags) (cdr f-tags) (cons ct seen-tags))
(error error-sym
"constructor disagrees with field specs: ~S ~S"
ct
ft))))))))
(define-syntax define-record-type
(syntax-rules ()
((_ TYPE CONSTRUCTOR-SPEC PREDICATE FIELD-SPECS ...)
(define-record-type/write
TYPE CONSTRUCTOR-SPEC PREDICATE #f FIELD-SPECS ...))))
(provide
define-record-type
define-record-type/write)