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

letrec: consider outside bindings safe.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-12-08 19:25:02 -05:00
parent 368f345901
commit b045153177
3 changed files with 9 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/drracket/private/insert-large-letters.rkt
View File

@ -103,7 +103,7 @@
(: ok Any) (: ok Any)
(: cancel Any) (: cancel Any)
(define-values (ok cancel) (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]) (set! ok? #t) (send dlg show #f))
(λ: ([x : Any] [y : Any]) (send dlg show #f)))) (λ: ([x : Any] [y : Any]) (send dlg show #f))))
(: update-txt (String -> Any)) (: update-txt (String -> Any))
@ -112,11 +112,11 @@
(send txt lock #f) (send txt lock #f)
(send txt delete 0 (send txt last-position)) (send txt delete 0 (send txt last-position))
(let ([bm (render-large-letters comment-prefix comment-character (get-chosen-font) str txt)]) (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 lock #t)
(send txt end-edit-sequence) (send txt end-edit-sequence)
(send (assert count defined?) set-label (format columns-string (get-max-line-width txt))) (send count set-label (format columns-string (get-max-line-width txt)))
(send (assert dark-msg defined?) set-bm bm))) (send dark-msg set-bm bm)))
;; CHANGE - get-face can return #f ;; CHANGE - get-face can return #f

11
collects/tests/typed-scheme/fail/safe-letrec.rkt
View File

@ -5,14 +5,3 @@
;; make sure letrec takes into account that some bidings may be undefined ;; make sure letrec takes into account that some bidings may be undefined
(+ (letrec: ([x : Float x]) x) 1) ; PR 11511 (+ (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)

8
collects/typed-scheme/typecheck/tc-let-unit.rkt
View File

@ -139,7 +139,7 @@
[transitively-safe-bindings '()]) [transitively-safe-bindings '()])
([names names] ([names names]
[clause clauses]) [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 -> safe to mention in a subsequent rhs
[(transitively-safe) (values (append names safe-bindings) [(transitively-safe) (values (append names safe-bindings)
(append names transitively-safe-bindings))] (append names transitively-safe-bindings))]
@ -178,11 +178,13 @@
;; Fixing Letrec (reloaded) paper), we are more conservative than a fully-connected component ;; 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 ;; based approach. On the other hand, our algorithm should cover most interesting cases and
;; is much simpler than Tarjan's. ;; 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 (define clause-rhs
(syntax-parse clause (syntax-parse clause
[(bindings . rhs) #'rhs])) [(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 (apply append
(syntax-map (lambda (x) (free-vars x)) (syntax-map (lambda (x) (free-vars x))
clause-rhs))) clause-rhs)))