Fix typechecking of `#%variable-reference'

This commit is contained in:
Sam Tobin-Hochstadt 2011-08-13 16:10:45 -04:00
parent 25084de5a7
commit 2d094db270
2 changed files with 30 additions and 29 deletions

View File

@ -22,16 +22,16 @@
syntax/parse syntax/parse
(for-syntax (utils tc-utils) (for-syntax (utils tc-utils)
(typecheck typechecker) (typecheck typechecker)
(env global-env) (env global-env)
(base-env #;base-env #;base-env-numeric (base-env #;base-env #;base-env-numeric
base-env-indexing base-special-env)) base-env-indexing base-special-env))
racket/file racket/file
(for-template (for-template
(base-env #;base-env base-types base-types-extra (base-env #;base-env base-types base-types-extra
#;base-env-numeric #;base-env-numeric
base-special-env base-special-env
base-env-indexing)) base-env-indexing))
(for-syntax syntax/kerncase syntax/parse)) (for-syntax syntax/kerncase syntax/parse))
(require (prefix-in b: (base-env base-env)) (require (prefix-in b: (base-env base-env))
@ -111,10 +111,10 @@
(define-for-syntax (local-expand/top-level form) (define-for-syntax (local-expand/top-level form)
(let ([form* (local-expand form 'module (kernel-form-identifier-list #'here))]) (let ([form* (local-expand form 'module (kernel-form-identifier-list #'here))])
(kernel-syntax-case form* #f (kernel-syntax-case form* #f
[(define-syntaxes . _) (raise-syntax-error "don't use syntax defs here!" form)] [(define-syntaxes . _) (raise-syntax-error "don't use syntax defs here!" form)]
[(define-values vals body) [(define-values vals body)
(quasisyntax/loc form (define-values vals #,(local-expand #'body 'expression '())))] (quasisyntax/loc form (define-values vals #,(local-expand #'body 'expression '())))]
[e (local-expand #'e 'expression '())]))) [e (local-expand #'e 'expression '())])))
;; check that typechecking this expression fails ;; check that typechecking this expression fails
(define-syntax tc-err (define-syntax tc-err
@ -228,11 +228,11 @@
[tc-e (let: ([x : (Un #f Number) 7]) [tc-e (let: ([x : (Un #f Number) 7])
(if x (+ x 1) 3)) (if x (+ x 1) 3))
N] N]
[tc-e (let: ([x : Number 1]) [tc-e (let: ([x : Number 1])
(if (and (number? x) #t) (if (and (number? x) #t)
(+ x 4) (+ x 4)
'bc)) 'bc))
N] N]
[tc-e/t (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)] [tc-e/t (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)]
[tc-e/t (begin 3) -PosByte] [tc-e/t (begin 3) -PosByte]
[tc-e/t (begin #f 3) -PosByte] [tc-e/t (begin #f 3) -PosByte]
@ -702,7 +702,6 @@
: (-FS (-not-filter (-val #f) #'map) (-filter (-val #f) #'map))))] : (-FS (-not-filter (-val #f) #'map) (-filter (-val #f) #'map))))]
;; error tests ;; error tests
[tc-err (#%variable-reference number?)]
[tc-err (+ 3 #f)] [tc-err (+ 3 #f)]
[tc-err (let: ([x : Number #f]) x)] [tc-err (let: ([x : Number #f]) x)]
[tc-err (let: ([x : Number #f]) (+ 1 x))] [tc-err (let: ([x : Number #f]) (+ 1 x))]
@ -1357,7 +1356,7 @@
(tc-e (let: ((p : (Promise Symbol) (delay 's))) (tc-e (let: ((p : (Promise Symbol) (delay 's)))
(promise-running? p)) B) (promise-running? p)) B)
|# |#
;; excetion handling ;; excetion handling
[tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" "")) [tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" ""))
#:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))] #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))]
@ -1385,10 +1384,13 @@
exn:break exn:break
arity-at-least arity-at-least
date date
srcloc) srcloc)
-Void) -Void)
[tc-e (raise (exn:fail:contract "1" (current-continuation-marks))) (t:Un)] [tc-e (raise (exn:fail:contract "1" (current-continuation-marks))) (t:Un)]
[tc-err (exn:fail:contract)] [tc-err (exn:fail:contract)]
[tc-e (#%variable-reference) -Variable-Reference]
[tc-e (#%variable-reference x) -Variable-Reference]
[tc-e (#%variable-reference +) -Variable-Reference]
) )
(test-suite (test-suite
"check-type tests" "check-type tests"
@ -1431,14 +1433,13 @@
#;(define (tc-toplevel-tests) #;(define (tc-toplevel-tests)
#reader typed-scheme/typed-reader #reader typed-scheme/typed-reader
(test-suite "Tests for tc-toplevel" (test-suite "Tests for tc-toplevel"
(tc-tl 3) (tc-tl 3)
(tc-tl (define: x : Number 4)) (tc-tl (define: x : Number 4))
(tc-tl (define: (f [x : Number]) : Number x)) (tc-tl (define: (f [x : Number]) : Number x))
[tc-tl (pdefine: (a) (f [x : a]) : Number 3)] [tc-tl (pdefine: (a) (f [x : a]) : Number 3)]
[tc-tl (pdefine: (a b) (mymap [f : (a -> b)] (l : (list-of a))) : (list-of b) [tc-tl (pdefine: (a b) (mymap [f : (a -> b)] (l : (list-of a))) : (list-of b)
(if (null? l) #{'() : (list-of b)} (if (null? l) #{'() : (list-of b)}
(cons (f (car l)) (map f (cdr l)))))])) (cons (f (car l)) (map f (cdr l)))))]))
(define-go typecheck-tests #;tc-toplevel-tests) (define-go typecheck-tests #;tc-toplevel-tests)

View File

@ -272,9 +272,9 @@
(ret -Void))] (ret -Void))]
;; top-level variable reference - occurs at top level ;; top-level variable reference - occurs at top level
[(#%top . id) (check-below (tc-id #'id) expected)] [(#%top . id) (check-below (tc-id #'id) expected)]
;; weird
[(#%variable-reference . _) [(#%variable-reference . _)
(tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Racket")] (ret -Variable-Reference)]
;; identifiers ;; identifiers
[x:identifier [x:identifier
(check-below (tc-id #'x) expected)] (check-below (tc-id #'x) expected)]
@ -389,9 +389,9 @@
[(#%top . id) (tc-id #'id)] [(#%top . id) (tc-id #'id)]
;; #%expression ;; #%expression
[(#%expression e) (tc-expr #'e)] [(#%expression e) (tc-expr #'e)]
;; weird ;; #%variable-reference
[(#%variable-reference . _) [(#%variable-reference . _)
(tc-error/expr #:return (ret (Un)) "#%variable-reference is not supported by Typed Racket")] (ret -Variable-Reference)]
;; identifiers ;; identifiers
[x:identifier (tc-id #'x)] [x:identifier (tc-id #'x)]
;; application ;; application