; 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-identifier? a b) (or (and (module-identifier=? a b) (printf "module-identifier=?~n") #t) (and (free-identifier=? a b) (printf "free-identifier=?~n") #t) (and (bound-identifier=? a b) (printf "bound-identifier=?~n") #t))) (define-for-syntax identifier-register ()) (define-for-syntax (register-identifiers constr fields accs muts) (set! identifier-register (cons (list constr fields accs muts) identifier-register))) (define-for-syntax (register-lookup constr) (let register-lookup ((register identifier-register)) (cond ((null? register) (raise-syntax-error 'module-dot "unknown struct-constructor" constr constr)) ((compare-identifier? (caar register) constr) (apply values (cdar register))) (else (register-lookup (cdr register)))))) (define-for-syntax (make-dotted-var var field) (datum->syntax-object var (string->symbol (string-append (symbol->string (syntax-e var)) "." (symbol->string (syntax-e field)))))) (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 ((fields #'(field ...))) (let ((accs (generate-temporaries fields)) (muts (generate-temporaries fields))) (register-identifiers #'constr fields accs muts) #`(define-values (descr constr pred #,@accs #,@muts) (let-values (((descr constr pred accessor mutator) (make-struct-type 'descr super #,(length (syntax->list #'(field ...))) 0 #f () inspector #f () #f))) #,@(let loop ((n 0) (accs accs) (muts muts)) (if (null? accs) () (let ((acc (car accs)) (accs (cdr accs)) (mut (car muts)) (muts (cdr muts))) (cons #`(define #,acc (make-struct-field-accessor accessor #,n)) (cons #`(define #,mut (make-struct-field-mutator mutator #,n)) (loop (add1 n) accs muts)))))) (values descr constr pred #,@accs #,@muts)))))))) (define-syntax (define-struct-var stx) (syntax-case stx () ((define-struct-var var (constr expr ...)) (let-values (((fields accs muts) (register-lookup #'constr)) ((var) #'var)) #`(begin (define #,var (constr expr ...)) #,@(map (lambda (field acc mut) (let ((dotted-var (make-dotted-var var field))) #`(define-syntax #,dotted-var (make-set!-transformer (lambda (stx) (syntax-case stx (set!) ((set! id v) #'(#,mut #,var v)) ((id x (... ...)) #'((#,acc #,var) x (... ...))) (id #'(#,acc #,var)))))))) (syntax->list fields) accs muts)))))) (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)) (require dot) "one" ; --> "one" (define-struct-type d c p (x y z) (make-inspector)) "two" ; --> "two" (define-struct-var s (c 1 2 add1)) "three" ; --> "three" d ; --> # c ; --> # p ; --> # s ; --> #(struct:d 1 2 3) (p s) "four" ; --> "four" s.x ; error : compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: acc1 ;(set! s.x 3) ; error : compile: bad syntax; reference to top-level identifier is not allowed, because no #%top syntax transformer is bound in: mut2