From b045153177afe8aaebdbf179dbe27670b1cf577d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 8 Dec 2010 19:25:02 -0500 Subject: [PATCH] letrec: consider outside bindings safe. --- collects/drracket/private/insert-large-letters.rkt | 8 ++++---- collects/tests/typed-scheme/fail/safe-letrec.rkt | 11 ----------- collects/typed-scheme/typecheck/tc-let-unit.rkt | 8 +++++--- 3 files changed, 9 insertions(+), 18 deletions(-) diff --git a/collects/drracket/private/insert-large-letters.rkt b/collects/drracket/private/insert-large-letters.rkt index 47228d559f..edc6a51f78 100644 --- a/collects/drracket/private/insert-large-letters.rkt +++ b/collects/drracket/private/insert-large-letters.rkt @@ -103,7 +103,7 @@ (: ok Any) (: cancel Any) (define-values (ok cancel) - (gui-utils:ok/cancel-buttons (assert button-panel defined?) + (gui-utils:ok/cancel-buttons button-panel (λ: ([x : Any] [y : Any]) (set! ok? #t) (send dlg show #f)) (λ: ([x : Any] [y : Any]) (send dlg show #f)))) (: update-txt (String -> Any)) @@ -112,11 +112,11 @@ (send txt lock #f) (send txt delete 0 (send txt last-position)) (let ([bm (render-large-letters comment-prefix comment-character (get-chosen-font) str txt)]) - (send (assert ec defined?) set-line-count (+ 1 (send txt last-paragraph))) + (send ec set-line-count (+ 1 (send txt last-paragraph))) (send txt lock #t) (send txt end-edit-sequence) - (send (assert count defined?) set-label (format columns-string (get-max-line-width txt))) - (send (assert dark-msg defined?) set-bm bm))) + (send count set-label (format columns-string (get-max-line-width txt))) + (send dark-msg set-bm bm))) ;; CHANGE - get-face can return #f diff --git a/collects/tests/typed-scheme/fail/safe-letrec.rkt b/collects/tests/typed-scheme/fail/safe-letrec.rkt index febfb83358..5e04f490ac 100644 --- a/collects/tests/typed-scheme/fail/safe-letrec.rkt +++ b/collects/tests/typed-scheme/fail/safe-letrec.rkt @@ -5,14 +5,3 @@ ;; make sure letrec takes into account that some bidings may be undefined (+ (letrec: ([x : Float x]) x) 1) ; PR 11511 - -(letrec: ([x : Number 3] - [y : Number z] ; bad - [z : Number x]) - z) - -(letrec: ([x : Number 3] - [y : (Number -> Number) (lambda (x) z)] ; bad - [z : Number x] - [w : (Number -> Number) (lambda (x) (y x))]) ; bad too - z) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt index 447dba5a18..2d8f6da33d 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt @@ -139,7 +139,7 @@ [transitively-safe-bindings '()]) ([names names] [clause clauses]) - (case (safe-letrec-values-clause? clause transitively-safe-bindings) + (case (safe-letrec-values-clause? clause transitively-safe-bindings flat-names) ;; transitively safe -> safe to mention in a subsequent rhs [(transitively-safe) (values (append names safe-bindings) (append names transitively-safe-bindings))] @@ -178,11 +178,13 @@ ;; Fixing Letrec (reloaded) paper), we are more conservative than a fully-connected component ;; based approach. On the other hand, our algorithm should cover most interesting cases and ;; is much simpler than Tarjan's. -(define (safe-letrec-values-clause? clause transitively-safe-bindings) +(define (safe-letrec-values-clause? clause transitively-safe-bindings letrec-bound-ids) (define clause-rhs (syntax-parse clause [(bindings . rhs) #'rhs])) - (cond [(andmap (lambda (fv) (s:member fv transitively-safe-bindings bound-identifier=?)) + (cond [(andmap (lambda (fv) + (or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside + (s:member fv transitively-safe-bindings bound-identifier=?))) (apply append (syntax-map (lambda (x) (free-vars x)) clause-rhs)))