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

Use stxclass for `require/typed'.

Browse Source 
svn: r13658
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-16 14:16:36 +00:00
parent 62ef5b2814
commit 54d17355c3
1 changed files with 30 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/typed-scheme/private/prims.ss
View File

@ -25,6 +25,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(require (except-in "../utils/utils.ss" extend))
(require (for-syntax
stxclass
stxclass/util
scheme/base
(rep type-rep)
mzlib/match
@ -54,40 +55,33 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax (require/typed stx)
(syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(_ lib [nm ty] ...)
(define-syntax (require/typed stx)
(define-syntax-class opt-rename
#:attributes (nm spec)
(pattern nm:id
#:with spec #'nm)
(pattern (orig-nm:id internal-nm:id)
#:with spec #'(orig-nm internal-nm)
#:with nm #'internal-nm))
(syntax-parse stx
[(_ lib [nm:opt-rename ty] ...)
#'(begin (require/typed nm ty lib) ...)]
[(_ nm ty lib #:struct-maker parent)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
(quasisyntax/loc stx (begin
#,(syntax-property (syntax-property #'(define cnt* #f)
'typechecker:contract-def/maker #'ty)
'typechecker:ignore #t)
#,(internal #'(require/typed-internal nm ty #:struct-maker parent))
#,(syntax-property #'(require/contract nm cnt* lib)
'typechecker:ignore #t))))]
[(_ nm ty lib)
(identifier? #'nm)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
(quasisyntax/loc stx (begin
#,(syntax-property (syntax-property #'(define cnt* #f)
'typechecker:contract-def #'ty)
'typechecker:ignore #t)
#,(internal #'(require/typed-internal nm ty))
#,(syntax-property #'(require/contract nm cnt* lib)
'typechecker:ignore #t))))]
[(_ (orig-nm nm) ty lib)
(and (identifier? #'nm)
(identifier? #'orig-nm))
(with-syntax ([(cnt*) (syntax->datum #'(nm))])
(quasisyntax/loc stx (begin
#,(syntax-property (syntax-property #'(define cnt* #f)
'typechecker:contract-def #'ty)
'typechecker:ignore #t)
#,(internal #'(require/typed-internal nm ty))
#,(syntax-property #'(require/contract (orig-nm nm) cnt* lib)
'typechecker:ignore #t))))]))
[(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*)
(with-syntax ([cnt* (generate-temporary #'nm.nm)]
[sm (if #'parent
#'(#:struct-maker parent)
#'())])
(let ([prop-name (if #'parent
'typechecker:contract-def/maker
'typechecker:contract-def)])
(quasisyntax/loc stx
(begin
#,(syntax-property (syntax-property #'(define cnt #f)
prop-name #'ty)
'typechecker:ignore #t)
#,(internal #'(require/typed-internal nm.nm ty . sm))
#,(syntax-property #'(require/contract nm.spec cnt lib)
'typechecker:ignore #t)))))]))
(define-syntax (require/opaque-type stx)
(syntax-case stx ()
@ -357,7 +351,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
(identifier? #'nm)
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
#`(begin
(quasisyntax/loc stx
(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(lambda ()
@ -372,7 +367,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f)
(require/typed lib
[sel (nm -> ty)]) ...))]
[sel (nm -> ty)]) ...)))]
[(_ (nm parent) ([fld : ty] ...) lib)
(and (identifier? #'nm) (identifier? #'parent))
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]