#| Module dot: for dotted notation of struct-fields for both references and assignments. By Jacob J. A. Koot with thanks to Jens Axel Søgaard. Syntax: (define-struct-type (def name constr pred [super-type-expr]) (field ...) [inspector-expr]) --> void Syntax: (define-struct-type def name constr pred (field ...) [inspector-expr]) --> void def, name, constr and pred must be distinct identifiers. The super-type-expr is evaluated and must yield #f or a struct-type-decriptor. The inspector-expr is evaluated and must yield #f or a struct inspector. All fields must be distinct identifiers. The following definitions are made (at top level or as internal-defs. def : syntax: (def var (expr ...)) --> void var must be an identifier The variable is defined (either at top level or as an internal-def) such as to contain an instance of the struct-type with the values of the exprs for its fields. The number of exprs must correspond to the number of fields. In addition syntaxes var.field are defined such that: varref var.field returns the current contents of the field. (set! var.field value) stores the value in the field. (var.field arg ...) assumes the field to contain a procedure and applies the procedure to the args. name : struct type descriptor that can be used as a super type for other struct types. constr : procedure (constr expr ...) --> instance of the struct type. pred : procedure (pred object) --> #t if the object is an instance of the struct type, else #f Syntax: (let-struct-type (binding ...) internal-def ... body-expr ...) Where binding ::= ((def name constr pred [super-type]) (field ...) [inspector-expr]) or ( def name constr pred (field ...) [inspector-expr]) Synatx let-struct-type is related to syntax define-struct-type as let to define. Syntax: (let-struct-var ((var def (expr ...)) ...) internal-def ... body ...) ==> (let () (def var (expr ...)) ... internal-def ... body ...) |# (module dot mzscheme (require-for-syntax (only (lib "etc.ss") build-list build-vector identity)) (require (only (lib "etc.ss") build-list build-vector identity)) (define-for-syntax (make-dotted-id stx var fld) (datum->syntax-object stx (string->symbol (string-append (symbol->string (syntax-e var)) "." (symbol->string (syntax-e fld)))))) (define-syntax (define-struct-type stx) (syntax-case stx () ((define-struct-type def name constr pred (field ...) ) #'(define-struct-type (def name constr pred #f ) (field ...) #f )) ((define-struct-type def name constr pred (field ...) inspector) #'(define-struct-type (def name constr pred #f ) (field ...) inspector)) ((define-struct-type (def name constr pred ) (field ...) ) #'(define-struct-type (def name constr pred #f ) (field ...) #f )) ((define-struct-type (def name constr pred super) (field ...) ) #'(define-struct-type (def name constr pred super) (field ...) #f )) ((define-struct-type (def name constr pred ) (field ...) inspector) #'(define-struct-type (def name constr pred #f ) (field ...) inspector)) ((define-struct-type (def name constr pred super) (field ...) inspector) (let ((nr-of-fields (length (syntax->list #'(field ...))))) #`(begin (define-values (name constr pred accessor mutator accessors mutators) (let-values (((name constr pred accessor mutator) (make-struct-type 'name super #,nr-of-fields 0 #f () inspector #f () #f))) (define accessors (build-vector #,nr-of-fields (lambda (i) (make-struct-field-accessor accessor i)))) (define mutators (build-vector #,nr-of-fields (lambda (i) (make-struct-field-mutator mutator i)))) (values name constr pred accessor mutator accessors mutators))) (define-syntax def (syntax-rules () ((def var (expr (... ...))) (begin (define var (constr expr (... ...))) (define-struct-trafos var constr (field ...) accessors mutators)))))))))) (define-syntax (define-struct-trafos stx) (syntax-case stx () ((define-struct-trafos var constr (field ...) accessors mutators) (let* ((fields (syntax->list #'(field ...))) (nr-of-fields (length fields)) (indices (build-list nr-of-fields identity))) #`(begin #,@(map (lambda (field index) #`(define-struct-trafo var #,field #,index accessors mutators)) fields indices)))))) (define-syntax (define-struct-trafo stx) (syntax-case stx () ((define-struct-trafo var field index accessors mutators) (with-syntax ((dotted-id (syntax-local-introduce (make-dotted-id #'stx #'var #'field)))) #`(define-syntax dotted-id (make-set!-transformer (lambda (tstx) (syntax-case tstx (set!) ((set! id v) #'((vector-ref mutators index) var v)) ((id x (... ...)) #'(((vector-ref accessors index) var) x (... ...))) (id #'((vector-ref accessors index) var)))))))))) (define-syntax let-struct-type (syntax-rules () ((let-struct-type (binding ...) . body) (let () (define-struct-type . binding) ... . body)))) (define-syntax let-struct-var (syntax-rules () ((let-struct-var ((var def (x ...)) ...) . body) (let () (def var (x ...)) ... . body)))) (provide define-struct-type let-struct-type let-struct-var) ; the following syntaxes must be exported, but are not ment to be called explicitly by the importing program (provide define-struct-trafos define-struct-trafo)) (require dot) ;;; tests ; Welcome to DrScheme, version 369.8-svn9mar2007 [3m]. ; Language: Textual (MzScheme, includes R5RS) custom (no debugging, case insensitive) (define-struct-type (def type constr pred) (x y z) (make-inspector)) ;--> void (list type constr pred) ; --> (# # #) (def var (1 2 add1)) ;--> void (set! var.x 10) ;--> void (list var var.x var.y (var.z 20)) ; --> (#(struct:type 10 2 #) 10 2 21) (let-struct-type (((d n c p) (x y z) (make-inspector))) (let-struct-var ((v d (1 2 add1))) (set! v.x 10) (printf "~s ~s ~s ~s~n" v v.x v.y (v.z 20)))) ;--> #(struct:n 10 2 #) 10 2 21 (define-struct-type (dd tt cc pp (car (list type))) ()) ;--> void (dd vv ('a 'b 'c)) ;--> void (list vv (pred vv) (pp vv)) ;--> (#(struct:tt a b c) #t #t)