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

remove syntax certificates; add syntax taints

Browse Source 
original commit: 1160d3df629ce65eb8fe9ebea2c33b8d4000ea50
This commit is contained in:
Matthew Flatt 2011-06-24 13:41:55 -06:00
parent c8c1cdc655
commit 5fb4f1af3a
9 changed files with 70 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/base-env/base-special-env.rkt
View File

@ -26,7 +26,6 @@
(initialize-type-env initial-env))
(provide (for-syntax initialize-env))))]))
(define-initial-env initialize-special
;; make-promise
[(syntax-parse (local-expand #'(delay 3) 'expression null)
@ -50,8 +49,7 @@
[(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f)
#:context #'make-sequence
#:literals (let-values quote)
[(let-values ([_ (m-s '(_) '())]) . _)
#'m-s])
[(let-values ([_ (m-s '(_) '())]) . _) #'m-s])
(-poly (a b)
(let ([seq-vals
(lambda (a)

10
collects/typed-scheme/core.rkt
View File

@ -11,7 +11,7 @@
(env type-name-env type-alias-env)
(r:infer infer)
(rep type-rep)
(except-in (utils utils tc-utils) infer)
(except-in (utils utils tc-utils arm) infer)
(only-in (r:infer infer-dummy) infer-param)
"tc-setup.rkt")
@ -40,7 +40,7 @@
[(optimized-body ...) (maybe-optimize #'transformed-body)])
;; reconstruct the module with the extra code
;; use the regular %#module-begin from `racket/base' for top-level printing
#`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))]))
(arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))]))
(define (ti-core stx)
(syntax-parse stx
@ -53,7 +53,7 @@
([optimized-body (car (maybe-optimize #`(#,body2)))])
(syntax-parse body2
;; any of these do not produce an expression to be printed
[(head:invis-kw . _) #'optimized-body]
[(head:invis-kw . _) (arm #'optimized-body)]
[_ (let ([ty-str (match type
;; don't print results of type void
[(tc-result1: (== -Void type-equal?)) #f]
@ -64,5 +64,5 @@
[x (int-err "bad type result: ~a" x)])])
(if ty-str
#`(let ([type '#,ty-str])
(begin0 optimized-body (display type)))
#'optimized-body))])))]))
(begin0 #,(arm #'optimized-body) (display type)))
(arm #'optimized-body)))])))]))

2
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -14,7 +14,7 @@
(define-syntax-class opt-expr
#:commit
(pattern e:opt-expr*
#:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
#:with opt #'e.opt))
(define-syntax-class opt-expr*
#:commit

6
collects/typed-scheme/tc-setup.rkt
View File

@ -11,7 +11,7 @@
(typecheck typechecker provide-handling tc-toplevel)
(env tvar-env type-name-env type-alias-env)
(r:infer infer)
(utils tc-utils)
(utils tc-utils disarm)
(rep type-rep)
(except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param)
@ -59,7 +59,7 @@
;; reinitialize seen type variables
[type-name-references null])
(do-time "Initialized Envs")
(let ([fully-expanded-stx (local-expand stx expand-ctxt null)])
(let ([fully-expanded-stx (disarm* (local-expand stx expand-ctxt null))])
(when (show-input?)
(pretty-print (syntax->datum fully-expanded-stx)))
(do-time "Local Expand Done")
@ -69,4 +69,4 @@
[debugging? #f])
(let ([result (checker fully-expanded-stx)])
(do-time "Typechecking Done")
. body)))))))
(let () . body))))))))

4
collects/typed-scheme/typecheck/tc-expr-unit.rkt
View File

@ -409,7 +409,9 @@
(begin (tc-exprs (syntax->list #'es))
(tc-expr #'e))]
;; other
[_ (tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a\n" (syntax->datum form))]))
[_
(printf "~s\n" (continuation-mark-set->context (current-continuation-marks)))
(tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a\n" (syntax->datum form))]))
(parameterize ([current-orig-stx form])
;(printf "form: ~a\n" (syntax->datum form))

4
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -50,7 +50,7 @@
#:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal
define-typed-struct/exec-internal :-internal assert-predicate-internal
require/typed-internal declare-refinement-internal
define-values quote-syntax #%plain-app begin)
define-values quote-syntax #%plain-app begin define-syntaxes)
;#:literal-sets (kernel-literals)
;; forms that are handled in other ways
@ -157,7 +157,7 @@
;; define-syntaxes just get noted
[(define-syntaxes (var:id ...) . rest)
(map make-def-stx-binding (syntax->list #'(var ...)))]
;; otherwise, do nothing in this pass
;; handles expressions, provides, requires, etc and whatnot
[_ (list)])))

25
collects/typed-scheme/utils/arm.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(require (for-template racket/base))
(provide arm)
;; For simplicity, protect everything produced by Typed Racket.
(define (arm stx)
(syntax-case stx (module #%plain-module-begin
#%require #%provide begin
define-values define-syntaxes
define-values-for-syntax)
[(module name initial-import mb)
(quasisyntax/loc stx (module name initial-import #,(arm #'mb)))]
[(#%plain-module-begin . _) (syntax-arm stx)]
[(#%require . _) stx]
[(#%provide . _) stx]
[(begin form ...)
(quasisyntax/loc stx (begin #,@(map arm (syntax->list #'(form ...)))))]
[(define-values ids expr)
(quasisyntax/loc stx (define-values ids #,(arm #'expr)))]
[(define-syntaxes ids expr)
(quasisyntax/loc stx (define-syntaxes ids #,(arm #'expr)))]
[(define-values-for-syntax ids expr)
(quasisyntax/loc stx (define-values-for-syntax ids #,(arm #'expr)))]
[_ (syntax-arm stx)]))

26
collects/typed-scheme/utils/disarm.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
(provide disarm*)
;; Typed Racket runs after macro expansion, and it must be priviledged,
;; so it can just disarm all taints (and arm everything afterward).
(define (disarm* stx)
(let loop ([v stx])
(cond
[(syntax? v)
(let* ([stx (syntax-disarm v orig-insp)]
[r (loop (syntax-e stx))])
(if (eq? r (syntax-e stx))
stx
(datum->syntax stx r stx stx)))]
[(pair? v) (let ([a (loop (car v))]
[d (loop (cdr v))])
(if (and (eq? a (car v))
(eq? d (cdr v)))
v
(cons a d)))]
[else v])))
(define orig-insp (current-code-inspector))

10
collects/typed/private/rewriter.rkt
View File

@ -2,10 +2,11 @@
(require (for-syntax syntax/parse racket/base syntax/id-table racket/dict
unstable/debug))
(define-for-syntax code-insp (current-code-inspector))
(define-for-syntax (rewrite stx tbl from)
(define (rw stx)
(syntax-recertify
(syntax-parse stx #:literal-sets (kernel-literals)
(syntax-parse (syntax-disarm stx code-insp) #:literal-sets (kernel-literals)
[i:identifier
(dict-ref tbl #'i #'i)]
;; no expressions here
@ -34,10 +35,7 @@
(~or if begin begin0 set! #%plain-app #%expression
#%variable-reference with-continuation-mark))
expr ...)
(quasisyntax/loc stx (#,#'kw #,@(map rw (syntax->list #'(expr ...)))))])
stx
(current-code-inspector)
#f))
(quasisyntax/loc stx (#,#'kw #,@(map rw (syntax->list #'(expr ...)))))]))
(rw stx))
(define-syntax (define-rewriter stx)