[plt-scheme] Dot-notation for structure field access

[jos koot]

Skipped content of type multipart/alternative-------------- next part --------------
; 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 #, at accs #, at 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 #, at accs #, at 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                                                   ; --> #<struct-type:d>
c                                                   ; --> #<primitive:make-d>
p                                                   ; --> #<primitive:d?>
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