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

Catch syntax lifting at the top-level in TR

Browse Source 
This is helpful for typechecking forms that lift
expressions such as object instantiation or contracted
values when they are used at the top-level.

It's not normally an issue for typechecking modules
because lifting is delimited by the module extent so that
normal local-expansion will cover it.
This commit is contained in:
Asumu Takikawa 2014-02-26 22:29:33 -05:00
parent 4b15bcedbf
commit 00470e3e1a
2 changed files with 42 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/tc-setup.rkt
View File

@ -3,6 +3,7 @@
(require "utils/utils.rkt"
(except-in syntax/parse id) syntax/stx
racket/pretty racket/promise racket/lazy-require
racket/syntax
(env type-name-env type-alias-env mvar-env)
(utils tc-utils disarm mutated-vars)
"standard-inits.rkt"
@ -42,7 +43,7 @@
(define-logger online-check-syntax)
(define (tc-setup orig-stx stx expand-ctxt checker k)
(define (tc-setup orig-stx stx expand-ctxt do-expand checker k)
(set-box! typed-context? #t)
;(start-timing (syntax-property stx 'enclosing-module-name))
(with-handlers
@ -58,7 +59,7 @@
;; reinitialize disappeared uses
[disappeared-use-todo null]
[disappeared-bindings-todo null])
(define fully-expanded-stx (disarm* (local-expand stx expand-ctxt (list #'module*))))
(define fully-expanded-stx (disarm* (do-expand stx expand-ctxt (list #'module*))))
(when (show-input?)
(pretty-print (syntax->datum fully-expanded-stx)))
(do-time "Local Expand Done")
@ -82,7 +83,26 @@
(apply k fully-expanded-stx results)))))))
(define (tc-toplevel/full orig-stx stx k)
(tc-setup orig-stx stx 'top-level tc-toplevel-form k))
(tc-setup orig-stx stx 'top-level local-expand/capture* tc-toplevel-form k))
(define (tc-module/full orig-stx stx k)
(tc-setup orig-stx stx 'module-begin tc-module k))
(tc-setup orig-stx stx 'module-begin local-expand tc-module k))
;; like `local-expand/capture-lifts` but expands the lifted expression, which
;; allows us to type-check lifted expressions at the top-level
(define (local-expand/capture* stx ctx stop-ids)
(define-values (defs expr)
;; at each iteration, get lifted definitions and the expanded expression
(let loop ([stx stx])
(define stx* (local-expand/capture-lifts stx ctx stop-ids))
(syntax-parse stx*
#:literals (begin define-values)
[(begin (define-values (n) e) ... e*)
(define-values (sub-defss defs)
(for/lists (_1 _2) ([e (in-list (syntax->list #'(e ...)))]
[n (in-list (syntax->list #'(n ...)))])
;; lifted expressions may re-lift, so recur
(define-values (sub-defs e-expanded) (loop e))
(values sub-defs #`(define-values (#,n) #,e-expanded))))
(values (append (apply append sub-defss) defs) #'e*)])))
#`(begin #,@defs #,expr))

18
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/lifting-top-level.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket/load
;; Test to make sure lifting is okay at the top-level for TR
;;
;; Would be best as a unit test, but the local expansion done in
;; tests is different from the local expansion done for #%top-interaction
(require typed/racket)
(define-syntax (m stx)
(syntax-local-lift-expression #'(string-append "foo" "bar")))
(m)
(define-syntax (n* stx)
(syntax-local-lift-expression #'(string-append "foo" "bar")))
(define-syntax (m* stx)
(syntax-local-lift-expression #'(n*)))
(m*)