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

It lives!

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-06-16 17:46:13 -04:00
parent 1b998d7eb8
commit 223c822154
5 changed files with 27 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/private/lexical-env.ss
View File

@ -21,7 +21,11 @@
;; identifer -> Type
(define (lookup-type/lexical i)
(lookup (lexical-env) i
(lambda (i) (lookup-type i))))
(lambda (i) (lookup-type
i (lambda ()
(if (lookup (dotted-env) i (lambda _ #f))
(tc-error "Rest variable ~a with ... type used in an inappropriate context" (syntax-e i))
(lookup-fail (syntax-e i))))))))
;; refine the type of i in the lexical env
;; (identifier type -> type) identifier -> environment

3
collects/typed-scheme/private/signatures.ss
View File

@ -53,3 +53,6 @@
(define-signature tc-let^
(tc/let-values tc/letrec-values tc/let-values/check tc/letrec-values/check))
(define-signature tc-dots^
(tc/dots))

19
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -12,13 +12,14 @@
"type-effect-printer.ss"
"type-annotation.ss"
"resolve-type.ss"
"type-environments.ss"
(only-in scheme/private/class-internal make-object do-make-object)
mzlib/trace mzlib/pretty syntax/kerncase scheme/match
(for-template
"internal-forms.ss" scheme/base
(only-in scheme/private/class-internal make-object do-make-object)))
(import tc-expr^ tc-lambda^)
(import tc-expr^ tc-lambda^ tc-dots^)
(export tc-app^)
;; comparators that inform the type system
@ -399,7 +400,8 @@
(define (tc/app/internal form expected)
(kernel-syntax-case* form #f
(values apply not list list* call-with-values do-make-object make-object cons) ;; the special-cased functions
(values apply not list list* call-with-values do-make-object make-object cons
andmap ormap) ;; the special-cased functions
;; special cases for classes
[(#%plain-app make-object cl args ...)
(tc/app/internal #'(#%plain-app do-make-object cl (#%plain-app list args ...) (#%plain-app list)) expected)]
@ -539,6 +541,19 @@
;(printf "special case~n")
(tc/rec-lambda/check form #'(args ...) #'body #'lp ts expected)
(ret expected))]
[(#%plain-app or/andmap f arg)
(and (or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap))
(with-handlers (#;[exn:fail? (lambda _ #f)])
(tc/dots #'arg)
#t))
(let-values ([(ty bound) (tc/dots #'arg)])
(parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound)))
(current-tvars))])
(match-let* ([ft (tc-expr #'f)]
[(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)])
(ret (Un (-val #f) t)))))]
;; default case
[(#%plain-app f args ...)
(begin

1
collects/typed-scheme/private/tc-utils.ss
View File

@ -41,7 +41,6 @@
stx))
(define (raise-typecheck-error msg stxs)
(printf "msg : ~a~n" msg)
(raise (make-exn:fail:syntax (string-append "typecheck: " msg)
(current-continuation-marks)
stxs)))

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

@ -5,10 +5,10 @@
(only-in scheme/unit provide-signature-elements)
"signatures.ss" "tc-toplevel.ss"
"tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss"
"tc-let-unit.ss"
"tc-let-unit.ss" "tc-dots-unit.ss"
"tc-expr-unit.ss" "check-subforms-unit.ss")
(provide-signature-elements typechecker^ tc-expr^)
(define-values/link-units/infer
tc-toplevel@ tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@)
tc-toplevel@ tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)