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

racket: keep old 'define-struct', include new form as 'struct'

Browse Source 
svn: r18789
This commit is contained in:
Matthew Flatt 2010-04-11 21:08:37 +00:00
parent bdb71498e3
commit 65d3d3240b
7 changed files with 268 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/mzlib/scribblings/unit.scrbl
View File

@ -37,3 +37,12 @@ but with a different syntax for the options that limit exports.}
A signature form like @scheme-struct/ctc from @schememodname[scheme/unit],
but with a different syntax for the options that limit exports.}
@deftogether[(
@defidform[struct~]
@defidform[struct~/ctc]
)]{
The same as @|scheme-struct| and @|scheme-struct/ctc| from
@schememodname[scheme/unit].}

216
collects/mzlib/unit.ss
View File

@ -21,7 +21,8 @@
"private/unit-contract.ss"
"private/unit-keywords.ss"
"private/unit-runtime.ss"
"private/unit-utils.ss")
"private/unit-utils.ss"
(rename-in racket/private/struct [struct struct~]))
(provide define-signature-form struct struct/ctc open
define-signature provide-signature-elements
@ -35,7 +36,8 @@
define-unit-binding
unit/new-import-export define-unit/new-import-export
unit/s define-unit/s
unit/c define-unit/contract)
unit/c define-unit/contract
struct~ struct~/ctc)
(define-syntax/err-param (define-signature-form stx)
(syntax-case stx ()
@ -130,6 +132,99 @@
((_)
(raise-stx-err "missing name and fields")))))
;; Replacement `struct' signature form for `scheme/unit':
(define-signature-form (struct~~ stx)
(syntax-case stx ()
((_ name (field ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))])
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?))
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?))])
(if no-ctr?
(cons (car names) (cddr names))
names))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx))))
(define-signature-form (struct/ctc stx)
(parameterize ((error-syntax stx))
(syntax-case stx ()
@ -214,6 +309,118 @@
((_)
(raise-stx-err "missing name and fields")))))
;; Replacement struct/ctc form for `scheme/unit':
(define-signature-form (struct~/ctc stx)
(syntax-case stx ()
((_ name ([field ctc] ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))])
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
[pred-ctc #'(-> any/c boolean?)]
[field-ctcs
(apply append
(map (λ (f c)
(cons #`(-> #,pred #,c)
(if (and (not mutable?)
(not (pair? (syntax-e f))))
null
#`(-> #,pred #,c void?))))
(syntax->list #'(field ...))
(syntax->list #'(ctc ...))))])
(list* (car l)
(list (cadr l) ctor-ctc)
(list pred pred-ctc)
(map list (cdddr l) field-ctcs))))
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?))
(let* ([names (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)))]
[cpairs (cons 'contracted
(if no-ctr? (cddr names) (cdr names)))])
(list (car names) cpairs))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx))))
;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig)
@ -395,7 +602,10 @@
(let ((trans
(set!-trans-extract
(syntax-local-value
(syntax-local-introduce #'x)
;; redirect struct~ to struct~~
(if (free-identifier=? #'x #'struct~)
#'struct~~
(syntax-local-introduce #'x))
(lambda ()
(raise-stx-err "unknown signature form" #'x))))))
(unless (signature-form? trans)

7
collects/racket/base.ss
View File

@ -1,6 +1,5 @@
#lang racket/private
(require "private/define-struct.ss")
(require "private/struct.rkt")
(provide (except-out (all-from-out scheme/base)
define-struct)
(rename-out [new-define-struct define-struct]))
(provide (all-from-out scheme/base)
struct)

7
collects/racket/main.ss
View File

@ -1,8 +1,7 @@
#lang racket/private
(require scheme)
(require "private/define-struct.ss")
;; scheme includes `struct' via scheme/unit
(provide (all-from-out scheme))
(provide (except-out (all-from-out scheme)
define-struct)
(rename-out [new-define-struct define-struct]))

23
collects/racket/private/define-struct.ss
View File

@ -1,23 +0,0 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide new-define-struct)
(define-syntax (new-define-struct stx)
(define (config-has-name? config)
(cond
[(syntax? config) (config-has-name? (syntax-e config))]
[(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
(config-has-name? (cdr config)))]
[else #f]))
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ id+super fields . config)
(not (config-has-name? #'config))
(with-syntax ([id (syntax-case #'id+super ()
[(id super) #'id]
[else #'id+super])])
(syntax/loc stx
(define-struct/derived orig id+super fields #:constructor-name id . config)))]
[_ (syntax/loc stx
(define-struct/derived orig id+super fields . config))])))

38
collects/racket/private/struct.rkt Normal file
View File

@ -0,0 +1,38 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide struct)
(define-syntax (struct stx)
(define (config-has-name? config)
(cond
[(syntax? config) (config-has-name? (syntax-e config))]
[(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
(config-has-name? (cdr config)))]
[else #f]))
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ id super-id fields . config)
(and (identifier? #'id)
(identifier? #'super-id))
(if (not (config-has-name? #'config))
(syntax/loc stx
(define-struct/derived orig (id super-id) fields #:constructor-name id . config))
(syntax/loc stx
(define-struct/derived orig (id super-id) fields . config)))]
[(_ id fields . config)
(identifier? #'id)
(if (not (config-has-name? #'config))
(syntax/loc stx
(define-struct/derived orig id fields #:constructor-name id . config))
(syntax/loc stx
(define-struct/derived orig id fields . config)))]
[(_ id . rest)
(identifier? #'id)
(syntax/loc stx
(define-struct/derived orig id . rest))]
[(_ thing . _)
(raise-syntax-error #f
"expected an identifier for the structure type name"
#'thing
stx)])))

208
collects/scheme/unit.ss
View File

@ -6,210 +6,6 @@
syntax/struct))
(provide (except-out (all-from-out mzlib/unit)
struct struct/ctc)
(rename-out [struct* struct]
[struct/ctc* struct/ctc]))
(rename-out [struct~ struct]
[struct~/ctc struct/ctc])))
;; Replacement `struct' signature form:
(define-signature-form (struct* stx)
(syntax-case stx ()
((_ name (field ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))])
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?))
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?))])
(if no-ctr?
(cons (car names) (cddr names))
names))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx))))
;; Replacement struct/ctc form
(define-signature-form (struct/ctc* stx)
(syntax-case stx ()
((_ name ([field ctc] ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))])
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
[pred-ctc #'(-> any/c boolean?)]
[field-ctcs
(apply append
(map (λ (f c)
(cons #`(-> #,pred #,c)
(if (and (not mutable?)
(not (pair? (syntax-e f))))
null
#`(-> #,pred #,c void?))))
(syntax->list #'(field ...))
(syntax->list #'(ctc ...))))])
(list* (car l)
(list (cadr l) ctor-ctc)
(list pred pred-ctc)
(map list (cdddr l) field-ctcs))))
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?))
(let* ([names (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)))]
[cpairs (cons 'contracted
(if no-ctr? (cddr names) (cdr names)))])
(list (car names) cpairs))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx)))))