; Language: Textual (MzScheme, includes R5RS), DrScheme version 369.8-svn9mar2007 [3m]. (module dot mzscheme ; for dotted notation of struct-fields for both references and assignments. (define-for-syntax (compare-id? a b) (or (module-identifier=? a b) (free-identifier=? a b) (bound-identifier=? a b))) (define-for-syntax register ()) (define-for-syntax (register-add! constr proc) (set! register (cons (cons constr proc) register))) (define-for-syntax (register-lookup constr) (let register-lookup ((register register)) (cond ((null? register) (raise-syntax-error 'module-dot "unknown struct-constructor" constr constr)) ((compare-id? (caar register) constr) (cdar register)) (else (register-lookup (cdr register)))))) (define-for-syntax (make-id var field) (datum->syntax-object var (string->symbol (string-append (symbol->string (syntax-e var)) "." (symbol->string (syntax-e field)))))) (define-for-syntax (register-transformer-builder constr fields acc mut) (register-add! constr (lambda (var) (let ((n 0)) (map (lambda (field) (let ((dotted-var (make-id var field))) (begin0 #`(define-syntax #,dotted-var (make-set!-transformer (lambda (stx) (syntax-case stx (set!) ((set! id v) #'((make-struct-field-mutator #,mut #,n) #,var v)) ((id x (... ...)) #'(((make-struct-field-accessor #,acc #,n) #,var) x (... ...))) (id #'((make-struct-field-accessor #,acc #,n) #,var)))))) (set! n (add1 n))))) (syntax->list fields)))))) (define-syntax (define-struct-type stx) (syntax-case stx () ((define-struct-type descr constr pred (field ...) ) #'(define-struct-type (descr constr pred #f ) (field ...) #f )) ((define-struct-type descr constr pred (field ...) inspector) #'(define-struct-type (descr constr pred #f ) (field ...) inspector)) ((define-struct-type (descr constr pred ) (field ...) ) #'(define-struct-type (descr constr pred #f ) (field ...) #f )) ((define-struct-type (descr constr pred super) (field ...) ) #'(define-struct-type (descr constr pred super) (field ...) #f )) ((define-struct-type (descr constr pred ) (field ...) inspector) #'(define-struct-type (descr constr pred #f ) (field ...) inspector)) ((define-struct-type (descr constr pred super) (field ...) inspector) (let-values (((acc mut) (apply values (generate-temporaries #'(acc mut))))) #`(begin (begin-for-syntax (let ([cert (syntax-local-certifier)]) (register-transformer-builder #'constr #'(field ...) (cert #'#,acc) (cert #'#,mut)))) (define-values (descr constr pred #,acc #,mut) (let-values (((descr constr pred #,acc #,mut) (make-struct-type 'descr super #,(length (syntax->list #'(field ...))) 0 #f () inspector #f () #f))) (values descr constr pred #,acc #,mut)))))))) (define-syntax (define-struct-var stx) (syntax-case stx () ((define-struct-var var (constr expr ...)) #`(begin (define var (constr expr ...)) #,@((register-lookup #'constr) #'var))))) (define-syntax let-struct-type (syntax-rules () ((let-struct-type (binding ...) . rest) (let () (define-struct-type . binding) ... . rest)))) (define-syntax let-struct-var (syntax-rules () ((let-struct-var (binding ...) . rest) (let () (define-struct-var . binding) ... . rest)))) (provide define-struct-type define-struct-var let-struct-type let-struct-var)) (module m mzscheme (require dot) (define-struct-type d c p (x y z) (make-inspector)) (provide d c p)) (module n mzscheme (require dot m) (define-struct-var s (c 1 2 add1)) (printf "~s\n" s.x)) (require n)