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

syntax/free-vars: fix quadratic behavior

Browse Source 
(Forgot to fix the "FIXME" before committing last time.)
This commit is contained in:
Matthew Flatt 2012-05-28 20:22:31 -06:00
parent ee93e35260
commit 6fded4bac1
2 changed files with 29 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/syntax/free-vars.rkt
View File

@ -31,22 +31,17 @@
[(pair? t) (loop (cdr t) (loop (car t) a))] [(pair? t) (loop (cdr t) (loop (car t) a))]
[else (error "internal error")])))) [else (error "internal error")]))))
;; formals->boundmap : formals-stx -> bound-map-table ;; formals->ids : formals-stx -> (listof identifier?)
;; Parses a procedure "formals" and returns the binding ids ;; Parses a procedure "formals" and returns the binding ids
;; in a table ;; in a table
(define (formals->boundmap f) (define (formals->ids f)
(let ([ids (let loop ([f f]) (let loop ([f f])
(cond (cond
[(identifier? f) (list f)] [(identifier? f) (list f)]
[(pair? f) (cons (car f) [(pair? f) (cons (car f)
(loop (cdr f)))] (loop (cdr f)))]
[(null? f) null] [(null? f) null]
[(syntax? f) (loop (syntax-e f))]))] [(syntax? f) (loop (syntax-e f))])))
[b (make-bound-identifier-mapping)])
(for-each (lambda (id)
(bound-identifier-mapping-put! b id #t))
ids)
b))
;; free-vars : expr-stx -> (listof id) ;; free-vars : expr-stx -> (listof id)
;; Returns a list of free lambda- and let-bound identifiers in a ;; Returns a list of free lambda- and let-bound identifiers in a
@ -54,24 +49,31 @@
(define (free-vars e [code-insp (define (free-vars e [code-insp
(variable-reference->module-declaration-inspector (variable-reference->module-declaration-inspector
(#%variable-reference))]) (#%variable-reference))])
;; It would be nicers to have a functional mapping:
(define bindings (make-bound-identifier-mapping))
(merge (merge
(let free-vars ([e e]) (let free-vars ([e e])
(kernel-syntax-case (syntax-disarm e code-insp) #f (kernel-syntax-case (syntax-disarm e code-insp) #f
[id [id
(identifier? #'id) (identifier? #'id)
(if (eq? 'lexical (identifier-binding #'id)) (if (and (eq? 'lexical (identifier-binding #'id))
(not (bound-identifier-mapping-get bindings #'id (lambda () #f))))
(list #'id) (list #'id)
null)] null)]
[(#%top . id) null] [(#%top . id) null]
[(quote q) null] [(quote q) null]
[(quote-syntax q) null] [(quote-syntax q) null]
[(#%plain-lambda formals expr ...) [(#%plain-lambda formals expr ...)
;; FIXME: this case makes the algorithm quadratic-time (let ([ids (formals->ids #'formals)])
(let ([free (merge (map free-vars (syntax->list #'(expr ...))))] (for ([id (in-list ids)])
[bindings (formals->boundmap #'formals)]) (bound-identifier-mapping-put! bindings id #t))
(filter (lambda (id) (begin0
(not (bound-identifier-mapping-get bindings id (lambda () #f)))) (map free-vars (syntax->list #'(expr ...)))
free))] ;; Since every binding should be distinct, it shouldn't
;; matter whether we map them back to #f, but just in case
;; we get a weird expression...
(for ([id (in-list ids)])
(bound-identifier-mapping-put! bindings id #f))))]
[(case-lambda [formals expr ...] ...) [(case-lambda [formals expr ...] ...)
(map free-vars (syntax->list (map free-vars (syntax->list
#'((#%plain-lambda formals expr ...) ...)))] #'((#%plain-lambda formals expr ...) ...)))]

7
collects/tests/syntax/free-vars.rkt
View File

@ -34,4 +34,9 @@
[y 2]) [y 2])
'(x) '(x)
(let-syntax ([ex (syntax-rules () [(foo) x])]) (let-syntax ([ex (syntax-rules () [(foo) x])])
(lambda (z) (ex)))))) (lambda (z) (ex)))))
(check #'(let ([x 1]
[y 2])
'(x)
(let ([y 3])
(list x y)))))