suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix build-struct-generation' to work with racket/base'

Browse Source 
and also still works with `mzscheme'
This commit is contained in:
Matthew Flatt 2011-09-03 07:45:26 -06:00
parent 981d6874de
commit 20a1440dcf
4 changed files with 72 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/syntax/scribblings/struct.scrbl
View File

@ -56,8 +56,8 @@ source location to the generated identifiers.}
[omit-set? boolean?]
[super-type any/c #f]
[prop-value-list list? empty]
[immutable-k-list list? empty])
[prop-value-list list? '(list)]
[immutable-k-list list? '(list)])
(listof identifier?)]{
Takes the same arguments as @racket[build-struct-names] and generates
@ -65,7 +65,7 @@ an S-expression for code using @racket[make-struct-type] to generate
the structure type and return values for the identifiers created by
@racket[build-struct-names]. The optional @racket[super-type],
@racket[prop-value-list], and @racket[immutable-k-list] parameters take
S-expression values that are used as the corresponding arguments to
S-expressions that are used as the corresponding argument expressions to
@racket[make-struct-type].}
@ -76,8 +76,8 @@ S-expression values that are used as the corresponding arguments to
[omit-sel? boolean?]
[omit-set? boolean?]
[super-type any/c #f]
[prop-value-list list? empty]
[immutable-k-list list? empty])
[prop-value-list list? '(list)]
[immutable-k-list list? '(list)])
(listof identifier?)]{
Like @racket[build-struct-generation], but given the names produced by

13
collects/syntax/struct.rkt
View File

@ -121,17 +121,17 @@
(loop (cdr l))))))))))
(define build-struct-generation
(lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
[immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]
(lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list '(list)]
[immutable-positions '(list)]
#:constructor-name [ctr-name #f])
(let ([names (build-struct-names name-stx fields omit-sel? omit-set?
#:constructor-name ctr-name)])
(build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list
immutable-positions mk-rec-prop-list))))
immutable-positions))))
(define build-struct-generation*
(lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null]
[immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)])
(lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list '(list)]
[immutable-positions '(list)])
(let ([num-fields (length fields)]
[acc/mut-makers (let loop ([l fields][n 0])
(if (null? l)
@ -151,8 +151,7 @@
(if omit-set?
null
(mk-one #f))
(loop (cdr l) (add1 n))))))]
[extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)])
(loop (cdr l) (add1 n))))))])
`(let-values ([(struct: make- ? acc mut)
(make-struct-type ',name ,super-type ,num-fields 0 #f
,prop-value-list (current-inspector)

29
collects/tests/syntax/mzstruct.rkt Normal file
View File

@ -0,0 +1,29 @@
#lang mzscheme
(require (for-syntax syntax/struct))
;; Like the "struct.rkt", but checks that it works in the
;; `mzscheme' language, still
(define-syntax (exp stx)
(syntax-case stx ()
[(_ sel? set? (name sup) (field ...))
(with-syntax ([e (build-struct-generation #'name
(syntax->list #'(field ...))
(not (syntax-e #'sel?))
(not (syntax-e #'set?))
(and (syntax-e #'sup) #'sup))]
[(id ...)
(build-struct-names #'name
(syntax->list #'(field ...))
(not (syntax-e #'sel?))
(not (syntax-e #'set?)))])
#'(define-values (id ...) e))]))
(define (check a b)
(unless (equal? a b) (error "failed!")))
(let ([set-pt-x! 12])
(exp #t #t (pt #f) (x y))
(check 10 (pt-x (make-pt 10 20)))
(check 20 (pt-y (make-pt 10 20)))
(check #t (procedure? set-pt-x!)))

32
collects/tests/syntax/struct.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket
(require (for-syntax syntax/struct))
(define-syntax (exp stx)
(syntax-case stx ()
[(_ sel? set? (name sup) (field ...))
(with-syntax ([e (build-struct-generation #'name
(syntax->list #'(field ...))
(not (syntax-e #'sel?))
(not (syntax-e #'set?))
(and (syntax-e #'sup) #'sup))]
[(id ...)
(build-struct-names #'name
(syntax->list #'(field ...))
(not (syntax-e #'sel?))
(not (syntax-e #'set?)))])
#'(define-values (id ...) e))]))
(define (check a b)
(unless (equal? a b) (error "failed!")))
(let ([set-pt-x! 12])
(exp #t #f (pt #f) (x y))
(check 10 (pt-x (make-pt 10 20)))
(check 20 (pt-y (make-pt 10 20)))
(check 12 set-pt-x!))
(let ([set-pt-x! 12])
(exp #t #t (pt #f) (x y))
(check 10 (pt-x (make-pt 10 20)))
(check 20 (pt-y (make-pt 10 20)))
(check #t (procedure? set-pt-x!)))