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 (except-in "../utils/utils.ss" extend))
(require (for-syntax (require (for-syntax
stxclass stxclass
stxclass/util
scheme/base scheme/base
(rep type-rep) (rep type-rep)
mzlib/match 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) (define-syntax (require/typed stx)
(syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) (define-syntax-class opt-rename
[(_ lib [nm ty] ...) #: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) ...)] #'(begin (require/typed nm ty lib) ...)]
[(_ nm ty lib #:struct-maker parent) [(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))]) (with-syntax ([cnt* (generate-temporary #'nm.nm)]
(quasisyntax/loc stx (begin [sm (if #'parent
#,(syntax-property (syntax-property #'(define cnt* #f) #'(#:struct-maker parent)
'typechecker:contract-def/maker #'ty) #'())])
'typechecker:ignore #t) (let ([prop-name (if #'parent
#,(internal #'(require/typed-internal nm ty #:struct-maker parent)) 'typechecker:contract-def/maker
#,(syntax-property #'(require/contract nm cnt* lib) 'typechecker:contract-def)])
'typechecker:ignore #t))))] (quasisyntax/loc stx
[(_ nm ty lib) (begin
(identifier? #'nm) #,(syntax-property (syntax-property #'(define cnt #f)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))]) prop-name #'ty)
(quasisyntax/loc stx (begin 'typechecker:ignore #t)
#,(syntax-property (syntax-property #'(define cnt* #f) #,(internal #'(require/typed-internal nm.nm ty . sm))
'typechecker:contract-def #'ty) #,(syntax-property #'(require/contract nm.spec cnt lib)
'typechecker:ignore #t) '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))))]))
(define-syntax (require/opaque-type stx) (define-syntax (require/opaque-type stx)
(syntax-case 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) (identifier? #'nm)
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]) [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
#`(begin (quasisyntax/loc stx
(begin
(require (only-in lib struct-info)) (require (only-in lib struct-info))
(define-syntax nm (make-struct-info (define-syntax nm (make-struct-info
(lambda () (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))) #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f) (require/typed maker nm lib #:struct-maker #f)
(require/typed lib (require/typed lib
[sel (nm -> ty)]) ...))] [sel (nm -> ty)]) ...)))]
[(_ (nm parent) ([fld : ty] ...) lib) [(_ (nm parent) ([fld : ty] ...) lib)
(and (identifier? #'nm) (identifier? #'parent)) (and (identifier? #'nm) (identifier? #'parent))
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]