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

sync to trunk

Browse Source 
svn: r13683
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-16 23:23:35 +00:00
parent 4056e03bc1
commit 347035fae9
1 changed files with 15 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -84,37 +84,21 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:ignore #t)))))])) 'typechecker:ignore #t)))))]))
(define-syntax (require/opaque-type stx) (define-syntax (require/opaque-type stx)
(syntax-case stx () (define-syntax-class name-exists-kw
[(_ ty pred lib #:name-exists) (pattern #:name-exists))
(begin (syntax-parse stx
(unless (identifier? #'ty) [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*)
(raise-syntax-error #f "opaque type name must be an identifier" stx #'ty)) (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
(unless (identifier? #'pred) (quasisyntax/loc stx
(raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred)) (begin
(register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier))) #,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?))
(quasisyntax/loc stx 'typechecker:ignore #t)
(begin #,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred))))
#,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?)) #,(if #'ne
'typechecker:ignore #t) (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred))))
#,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred)))) (syntax/loc stx (define-type-alias ty (Opaque pred))))
#,(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) #,(syntax-property #'(require/contract pred pred-cnt lib)
#,(syntax-property #'(require/contract pred pred-cnt lib) 'typechecker:ignore #t)))]))
'typechecker:ignore #t))))]
[(_ ty pred lib)
(begin
(unless (identifier? #'ty)
(raise-syntax-error #f "opaque type name must be an identifier" stx #'ty))
(unless (identifier? #'pred)
(raise-syntax-error #f "opaque type predicate must be an identifier" stx #'pred))
(register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
(quasisyntax/loc stx
(begin
#,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?))
'typechecker:ignore #t)
#,(internal #'(require/typed-internal pred (Any -> Boolean : (Opaque pred))))
(define-type-alias ty (Opaque pred))
#,(syntax-property #'(require/contract pred pred-cnt lib)
'typechecker:ignore #t))))]))
(define-for-syntax (formal-annotation-error stx src) (define-for-syntax (formal-annotation-error stx src)
(let loop ([stx stx]) (let loop ([stx stx])