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

syntax/free-vars: deterministic result order

Browse Source 
Closes PR 12798
This commit is contained in:
Matthew Flatt 2012-05-28 20:13:50 -06:00
parent 211e869fe1
commit ee93e35260
3 changed files with 94 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,20 +8,28 @@
(provide free-vars) (provide free-vars)
;; merge : (liftof (listof id)) -> (listof id) ;; An id-tree is either
;; - null
;; - id
;; - (cons id-tree id-tree)
;; merge : id-tree -> (listof id)
;; merges lists of identifiers, removing module-identifier=? ;; merges lists of identifiers, removing module-identifier=?
;; duplicates ;; duplicates
(define (merge l) (define (merge t)
(cond (define m (make-module-identifier-mapping))
[(null? l) null] (reverse
[(null? (cdr l)) (car l)] (let loop ([t t] [a null])
[else (let ([m (make-module-identifier-mapping)]) (cond
(for-each (lambda (ids) [(null? t) a]
(for-each (lambda (id) [(identifier? t)
(module-identifier-mapping-put! m id #t)) (if (module-identifier-mapping-get m t (lambda () #f))
ids)) a
l) (begin
(module-identifier-mapping-map m (lambda (k v) k)))])) (module-identifier-mapping-put! m t #t)
(cons t a)))]
[(pair? t) (loop (cdr t) (loop (car t) a))]
[else (error "internal error")]))))
;; formals->boundmap : formals-stx -> bound-map-table ;; formals->boundmap : formals-stx -> bound-map-table
;; Parses a procedure "formals" and returns the binding ids ;; Parses a procedure "formals" and returns the binding ids
@ -46,36 +54,38 @@
(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))])
(let free-vars ([e e]) (merge
(kernel-syntax-case (syntax-disarm e code-insp) #f (let free-vars ([e e])
[id (kernel-syntax-case (syntax-disarm e code-insp) #f
(identifier? #'id) [id
(if (eq? 'lexical (identifier-binding #'id)) (identifier? #'id)
(list #'id) (if (eq? 'lexical (identifier-binding #'id))
null)] (list #'id)
[(#%top . id) null] null)]
[(quote q) null] [(#%top . id) null]
[(quote-syntax q) null] [(quote q) null]
[(#%plain-lambda formals expr ...) [(quote-syntax q) null]
(let ([free (merge (map free-vars (syntax->list #'(expr ...))))] [(#%plain-lambda formals expr ...)
[bindings (formals->boundmap #'formals)]) ;; FIXME: this case makes the algorithm quadratic-time
(filter (lambda (id) (let ([free (merge (map free-vars (syntax->list #'(expr ...))))]
(not (bound-identifier-mapping-get bindings id (lambda () #f)))) [bindings (formals->boundmap #'formals)])
free))] (filter (lambda (id)
[(case-lambda [formals expr ...] ...) (not (bound-identifier-mapping-get bindings id (lambda () #f))))
(merge (map free-vars (syntax->list free))]
#'((#%plain-lambda formals expr ...) ...))))] [(case-lambda [formals expr ...] ...)
[(let-values ([(id ...) rhs] ...) expr ...) (map free-vars (syntax->list
(merge (cons (free-vars #'(#%plain-lambda (id ... ...) expr ...)) #'((#%plain-lambda formals expr ...) ...)))]
(map free-vars (syntax->list #'(rhs ...)))))] [(let-values ([(id ...) rhs] ...) expr ...)
[(letrec-values ([(id ...) rhs] ...) expr ...) (cons (free-vars #'(#%plain-lambda (id ... ...) expr ...))
(free-vars #'(#%plain-lambda (id ... ...) rhs ... expr ...))] (map free-vars (syntax->list #'(rhs ...))))]
[(letrec-syntaxes+values stx-bindings ([(id ...) rhs] ...) expr ...) [(letrec-values ([(id ...) rhs] ...) expr ...)
(free-vars #'(#%plain-lambda (id ... ...) rhs ... expr ...))] (free-vars #'(#%plain-lambda (id ... ...) rhs ... expr ...))]
[(kw expr ...) [(letrec-syntaxes+values stx-bindings ([(id ...) rhs] ...) expr ...)
(ormap (lambda (k) (free-identifier=? k #'kw)) (free-vars #'(#%plain-lambda (id ... ...) rhs ... expr ...))]
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%expression [(kw expr ...)
#'#%variable-reference #'with-continuation-mark)) (ormap (lambda (k) (free-identifier=? k #'kw))
(merge (map free-vars (syntax->list #'(expr ...))))] (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%expression
[(kw . _) #'#%variable-reference #'with-continuation-mark))
(error 'free-vars "unknown core form: ~a" (syntax->datum #'kw))]))) (map free-vars (syntax->list #'(expr ...)))]
[(kw . _)
(error 'free-vars "unknown core form: ~a" (syntax->datum #'kw))]))))

3
collects/syntax/scribblings/free-vars.scrbl
View File

@ -9,7 +9,8 @@
(listof identifier?)]{ (listof identifier?)]{
Returns a list of free @racket[lambda]- and @racket[let]-bound Returns a list of free @racket[lambda]- and @racket[let]-bound
identifiers in @racket[expr-stx]. The expression must be fully identifiers in @racket[expr-stx] in the order in which each
identifier first appears within @racket[expr-stx]. The expression must be fully
expanded (see @secref[#:doc refman "fully-expanded"] and expanded (see @secref[#:doc refman "fully-expanded"] and
@racket[expand]). @racket[expand]).

37
collects/tests/syntax/free-vars.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket
(require syntax/free-vars)
(parameterize ([current-namespace (make-base-namespace)])
(define (check stx)
(syntax-case (expand stx) (quote)
[(let-vals bindings (quote free) body)
(unless (andmap free-identifier=?
(syntax->list #'free)
(free-vars #'body))
(error "wrong answer: ~e" stx))]))
(check #'(let ([x 1])
'(x)
x))
(check #'(let ([x 1]
[y 2])
'(x y)
(x y)))
(check #'(let ([x 1]
[y 2])
'(y x)
(y x)))
(check #'(let ([x 1]
[y 2])
'(x y)
(let-syntax ([ex (syntax-rules () [(foo) x])])
(list x y (ex)))))
(check #'(let ([x 1]
[y 2])
'(x y)
(let-syntax ([ex (syntax-rules () [(foo) x])])
(list (ex) y x))))
(check #'(let ([x 1]
[y 2])
'(x)
(let-syntax ([ex (syntax-rules () [(foo) x])])
(lambda (z) (ex))))))