suzanne.soy/compatibility
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

original commit: 65d3d3240b647685f446f89d86b907f2bcc73b64
This commit is contained in:
Matthew Flatt 2010-04-11 21:08:37 +00:00
parent 23736d15be
commit 07e1c1fda1
1 changed files with 213 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

216
collects/mzlib/unit.ss
View File

@ -21,7 +21,8 @@
"private/unit-contract.ss" "private/unit-contract.ss"
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.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 (provide define-signature-form struct struct/ctc open
define-signature provide-signature-elements define-signature provide-signature-elements
@ -35,7 +36,8 @@
define-unit-binding define-unit-binding
unit/new-import-export define-unit/new-import-export unit/new-import-export define-unit/new-import-export
unit/s define-unit/s 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) (define-syntax/err-param (define-signature-form stx)
(syntax-case stx () (syntax-case stx ()
@ -130,6 +132,99 @@
((_) ((_)
(raise-stx-err "missing name and fields"))))) (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) (define-signature-form (struct/ctc stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(syntax-case stx () (syntax-case stx ()
@ -214,6 +309,118 @@
((_) ((_)
(raise-stx-err "missing name and fields"))))) (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) ;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig) (define-for-syntax (build-val+macro-defs sig)
@ -395,7 +602,10 @@
(let ((trans (let ((trans
(set!-trans-extract (set!-trans-extract
(syntax-local-value (syntax-local-value
(syntax-local-introduce #'x) ;; redirect struct~ to struct~~
(if (free-identifier=? #'x #'struct~)
#'struct~~
(syntax-local-introduce #'x))
(lambda () (lambda ()
(raise-stx-err "unknown signature form" #'x)))))) (raise-stx-err "unknown signature form" #'x))))))
(unless (signature-form? trans) (unless (signature-form? trans)