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

fix no-check

Browse Source 
svn: r18362

original commit: 5d3e46bb2f098eac10678e1d4d401c2f0401f382
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-26 20:50:14 +00:00
parent d98d962195
commit e3cf00137d
1 changed files with 42 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/typed-scheme/no-check.ss
View File

@ -1,31 +1,50 @@
#lang scheme/base
#;(require "private/prims.ss")
(require (except-in "private/prims.ss" require/typed require/opaque-type require-typed-struct))
(provide (all-from-out scheme/base)
(all-defined-out)
#;(all-from-out "private/prims.ss"))
(all-from-out "private/prims.ss"))
(define-syntax-rule (define-type-alias . _) (begin))
(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))
(define-syntax-class simple-clause
#:attributes (nm ty)
(pattern [nm:opt-rename ty]))
(define-syntax-class struct-clause
;#:literals (struct)
#:attributes (nm (body 1))
(pattern [struct nm:opt-rename (body ...)]
#:fail-unless (eq? 'struct (syntax-e #'struct)) #f))
(define-syntax-class opaque-clause
;#:literals (opaque)
#:attributes (ty pred opt)
(pattern [opaque ty:id pred:id]
#:fail-unless (eq? 'opaque (syntax-e #'opaque)) #f
#:with opt #'())
(pattern [opaque ty:id pred:id #:name-exists]
#:fail-unless (eq? 'opaque (syntax-e #'opaque)) #f
#:with opt #'(#:name-exists)))
(syntax-parse stx
[(_ lib (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
#'(begin
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
(require/typed sc.nm sc.ty lib) ...
(require-typed-struct strc.nm (strc.body ...) lib) ...)]
[(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...)
#'(require (only-in lib nm.spec))]))
(define-syntax-rule (define: nm _ _ . body)
(define nm . body))
(define-syntax-rule (require/opaque-type ty pred lib . _)
(require (only-in lib pred)))
(define-syntax-rule (ann e . rest) e)
(define-syntax-rule (inst e . rest) e)
(define-syntax (require-typed-struct stx)
(syntax-parse stx #:literals (:)
[(_ (~or nm:id (nm:id _:id)) ([fld : ty] ...) lib)
(with-syntax ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)])
#'(require (only-in lib struct-info maker pred sel ...)) ...)]))
(define-syntax-rule (require/typed mod [id . _] ...)
(require (only-in mod id ...)))
(define-syntax-rule (: . args) (begin))
(define-syntax let:
(syntax-rules ()
[(_ ([id _ _ . rest] ...) . b)
(let ([id . rest] ...) . b)]
[(_ id _ _ ([ids _ _ e] ...) . b)
(let id ([ids e] ...) . b)]))
(define-syntax-rule (lambda: ([id . rest] ...) . b)
(lambda (id ...) . b))
(define-syntax-rule (λ: . arg) (lambda: . arg))