<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML><HEAD>
<META http-equiv=Content-Type content="text/html; charset=iso-8859-1">
<META content="MSHTML 6.00.6000.16414" name=GENERATOR>
<STYLE></STYLE>
</HEAD>
<BODY bgColor=#ffffff>
<DIV>Got it now. See line tagged with <=====. Thanks for your help.</DIV>
<DIV>Soon I will add let-struct-type and let-struct-var.</DIV>
<DIV>Jos</DIV>
<DIV> </DIV>
<DIV>(module for-dot-transformers mzscheme<BR> (define-struct type
(name fields))<BR> (provide (struct type (name fields))))</DIV>
<DIV> </DIV>
<DIV>(module dot mzscheme ; for dotted notation of struct-fields for both
references and assignments.</DIV>
<DIV> </DIV>
<DIV> (require-for-syntax<BR>
for-dot-transformers<BR> (prefix srfi: (lib "1.ss" "srfi"))) ;
for srfi:assoc</DIV>
<DIV> </DIV>
<DIV> (begin-for-syntax<BR> (define types
'())<BR> (define (register-type! name
type)<BR> (set! types (cons (cons name type)
types)))<BR> (define (lookup-type
name)<BR>
(cond<BR> [(srfi:assoc name
types
module-identifier=?)<BR>
=> cdr]<BR>
[else<BR> (error
'lookup-type "unknown type: ~a\n" name)]))</DIV>
<DIV> </DIV>
<DIV> (define (->string
o)<BR>
(cond<BR> [(identifier? o)
(symbol->string (syntax-e
o))]<BR> [(symbol?
o) (symbol->string
o)]<BR> [(string?
o)
o]<BR>
[else<BR> (error
'->string<BR>
"expected, identifier, symbol, or string, got: ~a\n" o)]))</DIV>
<DIV> </DIV>
<DIV> (define (make-identifier stx . x) ; allow anu
number of components<BR>
(datum->syntax-object<BR> stx
(string->symbol<BR>
(apply string-append (map ->string x))))))</DIV>
<DIV> </DIV>
<DIV> ; (define-struct-type d c p (x y z)
(make-inspector))<BR> (define-syntax (define-struct-type
stx)<BR> (syntax-case stx
()<BR> ((define-struct-type name constr pred
(field ...))<BR> #'(define-struct-type
(name constr pred
#f)<BR>
(field ...) #f
))<BR> ((define-struct-type name constr pred
(field ...) inspector)<BR>
#'(define-struct-type (name constr pred #f
)<BR>
(field ...) inspector))<BR>
((define-struct-type (name constr pred) (field
...))<BR> #'(define-struct-type (name
constr pred #f
)<BR>
(field ...) #f
))<BR> ((define-struct-type (name constr
pred
super)<BR>
(field ...)
)<BR> #'(define-struct-type (name
constr pred
super)<BR>
(field ...) #f
))<BR> ((define-struct-type (name constr
pred
)<BR>
(field ...) inspector)<BR>
#'(define-struct-type (name constr pred #f
)<BR>
(field ...) inspector))<BR>
((define-struct-type (name constr pred
super)<BR>
(field ...) inspector)<BR>
(register-type!
#'name<BR>
(make-type
#'name<BR>
(syntax-object->datum #'(field
...))))<BR>
#`(begin<BR>
#,(syntax-case #'super
()<BR>
[#f #`(define-struct name (field ...)
inspector)]<BR>
[super #`(define-struct (name
super)<BR>
(field ...)
inspector)])<BR>
(define name #,(make-identifier stx 'struct ":"
#'name))<BR>
(define constr #,(make-identifier stx 'make "-"
#'name))<BR>
(define pred #,(make-identifier stx #'name "" "?"))))))</DIV>
<DIV><BR> (define-syntax (define-struct-var
stx)<BR> (syntax-case stx
()<BR> ((define-struct-var var type-name
(constr expr ...))<BR>
#`(begin<BR>
(define var (constr expr
...))<BR>
(define-dotted-accessors s type-name)))))</DIV>
<DIV> </DIV>
<DIV> (define-syntax (define-dotted-accessors
stx)<BR> (syntax-case stx
()<BR> [(define-dotted-accessors var
type-name)<BR>
#`(begin<BR>
#,@(map (lambda
(field)<BR>
(with-syntax<BR>
([var.field<BR>
(syntax-local-introduce<BR>
(make-identifier #'stx #'var "."
field))]<BR>
[type-name-field<BR>
(make-identifier<BR>
#'var #'type-name "-"
field)]<BR>
[set-type-name-field<BR>
(make-identifier #'var 'set- #'type-name "-" field
"!")])<BR>
#'(define-syntax
var.field<BR>
(make-set!-transformer
;<===========<BR>
(lambda
(stx)<BR>
(syntax-case stx
(set!)<BR>
[(set! ref v) #'(set-type-name-field var
v)]<BR>
[ref #'(type-name-field
var)]))))))<BR>
(type-fields (lookup-type #'type-name))))]))<BR> </DIV>
<DIV> </DIV>
<DIV><BR> (provide define-struct-type define-struct-var))</DIV>
<DIV> </DIV>
<DIV>;;; test</DIV>
<DIV> </DIV>
<DIV>(require dot)</DIV>
<DIV> </DIV>
<DIV>"one"
; --> "one"<BR>(define-struct-type d c p (x y z)
(make-inspector))<BR>"two"
; --> "two"<BR>(define-struct-var s d (make-d 1 2
add1))<BR>"three"
; -->
"three"<BR>struct:d
; -->
#<struct-type:d><BR>c
; -->
#<primitive:make-d><BR>d?
; -->
#<primitive:d?><BR>s
; --> #(struct:d 1 2 3)<BR>(p
s)<BR>"four"
; --> "four"<BR>s.x<BR>(set! s.x 3)<BR>s.x ; --> 3</DIV>
<DIV> </DIV>
<DIV>(((((lambda(x)((((((((x x)x)x)x)x)x)x)x))<BR>
(lambda(x)(lambda(y)(x(x y)))))<BR> (lambda(x)(x)x))<BR>
(lambda()(printf "Greetings, Jos~n"))))</DIV>
<BLOCKQUOTE
style="PADDING-RIGHT: 0px; PADDING-LEFT: 5px; MARGIN-LEFT: 5px; BORDER-LEFT: #000000 2px solid; MARGIN-RIGHT: 0px">
<DIV style="FONT: 10pt arial">----- Original Message ----- </DIV>
<DIV
style="BACKGROUND: #e4e4e4; FONT: 10pt arial; font-color: black"><B>From:</B>
<A title=jensaxel@soegaard.net href="mailto:jensaxel@soegaard.net">Jens Axel
Søgaard</A> </DIV>
<DIV style="FONT: 10pt arial"><B>To:</B> <A title=jensaxel@soegaard.net
href="mailto:jensaxel@soegaard.net">Jens Axel Søgaard</A> </DIV>
<DIV style="FONT: 10pt arial"><B>Cc:</B> <A title=jos.koot@telefonica.net
href="mailto:jos.koot@telefonica.net">jos koot</A> ; <A
title=plt-scheme@list.cs.brown.edu
href="mailto:plt-scheme@list.cs.brown.edu">plt-scheme@list.cs.brown.edu</A> ;
<A title=samth@ccs.neu.edu href="mailto:samth@ccs.neu.edu">Sam TH</A> </DIV>
<DIV style="FONT: 10pt arial"><B>Sent:</B> Sunday, March 11, 2007 5:10
PM</DIV>
<DIV style="FONT: 10pt arial"><B>Subject:</B> Re: [plt-scheme] Dot-notation
for structure field access</DIV>
<DIV><BR></DIV>Jens Axel Søgaard skrev:<BR>> jos koot skrev:<BR>>> Hi
Jens Axel,<BR>>> Thanks, Yes I guessed the problem was located
there.<BR>>> I understand that the two transformers produce
syntactically distinct <BR>>> identifiers, but I would not know how to
make them identical. I have <BR>>> tried (quasi)syntax/loc, but that did
not work either. Is there a <BR>>> solution for this problem? If so, can
you give me some extra hint? <BR>> <BR>> Haven't figured it out
yet.<BR><BR>Still haven't, but instead here is the beginning of
an<BR>alternative solution. The s.x syntax works now. If you want<BR>to avoid
the explicit use of the type in define-struct-var, then<BR>introduce a
registry for constructors to types as you had in<BR>your original
version.<BR><BR>Also (set! s.x expr) is missing in this version.<BR><BR>/Jens
Axe,<BR><BR><BR>(module for-dot-transformers mzscheme<BR>
(define-struct type (name fields))<BR> (provide (struct type (name
fields))))<BR><BR>(module dot mzscheme ; for dotted notation of struct-fields
for both <BR>references and assignments.<BR><BR>
(require-for-syntax<BR>
for-dot-transformers<BR> (prefix srfi: (lib "1.ss" "srfi")))
; for srfi:assoc<BR><BR>
(begin-for-syntax<BR> (define types
'())<BR> (define (register-type! name
type)<BR> (set! types (cons (cons name
type) types)))<BR> (define (lookup-type
name)<BR>
(cond<BR> [(srfi:assoc name
types
module-identifier=?)<BR>
=> cdr]<BR>
[else<BR> (error
'lookup-type "unknown type: ~a\n" name)]))<BR><BR>
(define (->string o)<BR>
(cond<BR> [(identifier? o)
(symbol->string (syntax-e
o))]<BR> [(symbol?
o) (symbol->string
o)]<BR> [(string?
o)
o]<BR>
[else<BR> (error
'->string<BR>
"expected, identifier, symbol, or string, got: ~a\n"
o)]))<BR><BR> (define (make-identifier stx before
between after)<BR>
(datum->syntax-object<BR> stx
(string->symbol<BR>
(string-append (->string
before)<BR>
between (->string after))))))<BR><BR> ; (define-struct-type d c
p (x y z) (make-inspector))<BR> (define-syntax (define-struct-type
stx)<BR> (syntax-case stx
()<BR> ((define-struct-type name constr
pred (field ...))<BR>
#'(define-struct-type (name constr pred
#f)<BR>
(field ...) #f
))<BR> ((define-struct-type name constr
pred (field ...) inspector)<BR>
#'(define-struct-type (name constr pred #f
)<BR>
(field ...) inspector))<BR>
((define-struct-type (name constr pred) (field
...))<BR> #'(define-struct-type
(name constr pred #f
)<BR>
(field ...) #f
))<BR> ((define-struct-type (name constr
pred
super)<BR>
(field ...)
)<BR> #'(define-struct-type (name
constr pred
super)<BR>
(field ...) #f
))<BR> ((define-struct-type (name constr
pred
)<BR>
(field ...) inspector)<BR>
#'(define-struct-type (name constr pred #f
)<BR>
(field ...) inspector))<BR>
((define-struct-type (name constr pred
super)<BR>
(field ...) inspector)<BR>
(register-type!
#'name<BR>
(make-type
#'name<BR>
(syntax-object->datum #'(field
...))))<BR>
#`(begin<BR>
#,(syntax-case #'super
()<BR>
[#f #`(define-struct name (field ...)
inspector)]<BR>
[super #`(define-struct (name
super)<BR>
(field ...)
inspector)])<BR>
(define name #,(make-identifier stx 'struct ":"
#'name))<BR>
(define constr #,(make-identifier stx 'make "-"
#'name))<BR>
(define pred #,(make-identifier stx #'name ""
"?"))))))<BR><BR><BR> (define-syntax (define-struct-var
stx)<BR> (syntax-case stx
()<BR> ((define-struct-var var type-name
(constr expr ...))<BR>
#`(begin<BR>
(define var (constr expr
...))<BR>
(define-dotted-accessors s type-name)))))<BR><BR> (define-syntax
(define-dotted-accessors stx)<BR> (syntax-case stx
()<BR> [(define-dotted-accessors var
type-name)<BR>
#`(begin<BR>
#,@(map (lambda
(field)<BR>
(with-syntax<BR>
([var.field<BR>
(syntax-local-introduce<BR>
(make-identifier #'stx #'var "."
field))]<BR>
[type-name-field<BR>
(make-identifier<BR>
#'var #'type-name "-"
field)])<BR>
#'(define-syntax (var.field
stx)<BR>
(syntax-case stx
()<BR>
[ref #'(type-name-field
var)]))))<BR>
(type-fields (lookup-type #'type-name))))]))<BR><BR> (provide
define-struct-type define-struct-var))<BR><BR>;;; test<BR><BR>(require
dot)<BR><BR>"one"
; --> "one"<BR>(define-struct-type d c p (x y z)
(make-inspector))<BR>"two"
; --> "two"<BR>(define-struct-var s d (make-d 1 2
add1))<BR>"three"
; -->
"three"<BR>struct:d
; -->
<BR>#<struct-type:d><BR>c
; -->
<BR>#<primitive:make-d><BR>d?
; -->
#<primitive:d?><BR>s
; --> #(struct:d 1 2 3)<BR>(p
s)<BR>"four"
; --> "four"<BR>s.x<BR>;(set! s.x 3)<BR><BR></BLOCKQUOTE></BODY></HTML>