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

New true-filter and false-filter abbrevs

Browse Source 
Fix for Stevie's d-s/c fix.
tc-expr now compiles

svn: r14007
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-07 22:51:54 +00:00
parent 09ee5d37a5
commit 18e03efc84
3 changed files with 31 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -1,14 +1,14 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [private r:private]))
(require (rename-in "../utils/utils.ss" [private private-in]))
(require syntax/kerncase
scheme/match
"signatures.ss"
(r:private type-utils type-effect-convenience union subtype
parse-type type-annotation stxclass-util)
(rep type-rep effect-rep)
(utils tc-utils)
(types utils convenience union subtype)
(private-in parse-type type-annotation)
(rep type-rep)
(utils tc-utils stxclass-util)
(env lexical-env)
(only-in (env type-environments) lookup current-tvars extend-env)
scheme/private/class-internal
@ -23,12 +23,18 @@
;; return the type of a literal value
;; scheme-value -> type
(define (tc-literal v-stx)
(define (tc-literal v-stx [expected #f])
(define-syntax-class exp
(pattern i
#:when expected
#:with datum (syntax-e #'i)
#:when (subtype (-val #'datum) expected)))
(syntax-parse v-stx
[i:exp expected]
[i:boolean (-val #'i.datum)]
[i:identifier (-val #'i.datum)]
[i:exact-integer -Integer]
[i:number N]
[i:number -Number]
[i:str -String]
[i:char -Char]
[i:keyword (-val #'i.datum)]
@ -99,12 +105,15 @@
;; tc-id : identifier -> tc-result
(define (tc-id id)
(let* ([ty (lookup-type/lexical id)])
(ret ty (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id)))))
(ret ty
(make-LFilterSet (list (make-NotTypeFilter (-val #f) null id))
(list (make-TypeFilter (-val #f) null id)))
(make-Path null id))))
;; typecheck an expression, but throw away the effect
;; tc-expr/t : Expr -> Type
(define (tc-expr/t e) (match (tc-expr e)
[(tc-result: t) t]
[(tc-result: t _ _) t]
[t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))]))
(define (tc-expr/check/t e t)
@ -148,9 +157,9 @@
(int-err "internal error: ignore-some"))
(check-below ty expected))]
;; data
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
[(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))]
[(quote val) (ret (tc-literal #'val))]
[(quote #f) (ret (-val #f) false-filter)]
[(quote #t) (ret (-val #t) true-filter)]
[(quote val) (ret (tc-literal #'val expected))]
;; syntax
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))]
;; mutation!
@ -232,8 +241,8 @@
ty)]
;; data
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
[(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))]
[(quote #f) (ret (-val #f) false-filter)]
[(quote #t) (ret (-val #t) true-filter)]
[(quote val) (ret (tc-literal #'val))]
;; syntax

4
collects/typed-scheme/types/abbrev.ss
View File

@ -24,6 +24,7 @@
(define -box make-Box)
(define -vec make-Vector)
(define -LFS make-LFilterSet)
(define -FS make-FilterSet)
(define-syntax *Un
(syntax-rules ()
@ -251,6 +252,9 @@
(->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))]
[(t) (make-pred-ty (list Univ) -Boolean t)]))
(define true-filter (-FS (list) (list (make-Bot))))
(define false-filter (-FS (list (make-Bot)) (list)))
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])

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

@ -167,15 +167,16 @@
;; this structure represents the result of typechecking an expression
(d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent)
(define-struct tc-result (t f o) #:transparent #:omit-define-values)
(define-match-expander tc-result:
(syntax-parser
[(_ tp fp op) #'(struct tc-result (tp fp op))]))
[(_ tp fp op) #'(struct tc-result (tp fp op))]
[(_ tp) #'(struct tc-result (tp _ _))]))
(define-match-expander tc-results:
(syntax-parser
[(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))]))
[(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))]
[(_ tp) #'(list (struct tc-result (tp _ _)) (... ...))]))
(provide tc-result: tc-results:)