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

compiles again

Browse Source 
svn: r14625
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-27 16:06:54 +00:00
parent 29e123ccf3
commit 8cbdf3ee95
6 changed files with 48 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/typed-scheme/env/type-environments.ss vendored
View File

@ -19,9 +19,6 @@
env-keys+vals env-keys+vals
with-dotted-env/extend) with-dotted-env/extend)
(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)]
[])
;; eq? has the type of equal?, and l is an alist (with conses!) ;; eq? has the type of equal?, and l is an alist (with conses!)
(define-struct env (eq? l)) (define-struct env (eq? l))
@ -87,3 +84,5 @@
(define-syntax with-dotted-env/extend (define-syntax with-dotted-env/extend
(syntax-rules () (syntax-rules ()
[(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)])) [(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)]))
(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)])

2
collects/typed-scheme/private/parse-type.ss
View File

@ -300,7 +300,7 @@
(and (eq? (syntax-e #'Refinement) 'Refinement) (and (eq? (syntax-e #'Refinement) 'Refinement)
(identifier? #'p?)) (identifier? #'p?))
(match (lookup-type/lexical #'p?) (match (lookup-type/lexical #'p?)
[(and t (Function: (list (arr: (list dom) rng #f #f '() _ _)))) [(and t (Function: (list (arr: (list dom) _ #f #f '()))))
(make-Refinement dom #'p? (syntax-local-certifier))] (make-Refinement dom #'p? (syntax-local-certifier))]
[t (tc-error "cannot declare refinement for non-predicate ~a" t)])] [t (tc-error "cannot declare refinement for non-predicate ~a" t)])]
[(Instance t) [(Instance t)

3
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -41,9 +41,10 @@
(list)] (list)]
;; declare-refinement ;; declare-refinement
;; FIXME - this sucks and should die
[(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values))) [(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values)))
(match (lookup-type/lexical #'pred) (match (lookup-type/lexical #'pred)
[(and t (Function: (list (arr: (list dom) rng #f #f '() _ _)))) [(and t (Function: (list (arr: (list dom) rng #f #f '()))))
(register-type #'pred (register-type #'pred
(make-pred-ty (list dom) (make-pred-ty (list dom)
rng rng

4
collects/typed-scheme/typecheck/typechecker.ss
View File

@ -13,5 +13,5 @@
(provide-signature-elements typechecker^ tc-expr^) (provide-signature-elements typechecker^ tc-expr^)
(define-values/link-units/infer (define-values/invoke-unit/infer
tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-new-app@ tc-let@ tc-expr@ check-subforms@) (link tc-toplevel@ tc-new-if@ tc-lambda@ tc-dots@ tc-new-app@ tc-let@ tc-expr@ check-subforms@))

17
collects/typed-scheme/types/utils.ss
View File

@ -29,7 +29,8 @@
(struct-out DottedBoth) (struct-out DottedBoth)
just-Dotted? just-Dotted?
tc-error/expr tc-error/expr
lookup-fail) lookup-fail
lookup-type-fail)
;; substitute : Type Name Type -> Type ;; substitute : Type Name Type -> Type
@ -254,4 +255,16 @@
return) return)
;; error for unbound variables ;; error for unbound variables
(define (lookup-fail e) (tc-error/expr "unbound identifier ~a" e)) (define (lookup-fail e)
(match (identifier-binding e)
['lexical (int-err "untyped lexical variable ~a" (syntax-e e))]
[#f (int-err "untyped top-level variable ~a" (syntax-e e))]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(let-values ([(x y) (module-path-index-split nominal-source-mod)])
(cond [(and (not x) (not y))
(tc-error/expr "untyped identifier ~a" (syntax-e e))]
[else
(tc-error/expr "untyped identifier ~a imported from module <~a>" (syntax-e e) x)]))]))
(define (lookup-type-fail i)
(tc-error/expr "~a is not bound as a type" (syntax-e i)))