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

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

@ -8,20 +8,28 @@
(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=?
;; duplicates
(define (merge l)
(define (merge t)
(define m (make-module-identifier-mapping))
(reverse
(let loop ([t t] [a null])
(cond
[(null? l) null]
[(null? (cdr l)) (car l)]
[else (let ([m (make-module-identifier-mapping)])
(for-each (lambda (ids)
(for-each (lambda (id)
(module-identifier-mapping-put! m id #t))
ids))
l)
(module-identifier-mapping-map m (lambda (k v) k)))]))
[(null? t) a]
[(identifier? t)
(if (module-identifier-mapping-get m t (lambda () #f))
a
(begin
(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
;; Parses a procedure "formals" and returns the binding ids
@ -46,6 +54,7 @@
(define (free-vars e [code-insp
(variable-reference->module-declaration-inspector
(#%variable-reference))])
(merge
(let free-vars ([e e])
(kernel-syntax-case (syntax-disarm e code-insp) #f
[id
@ -57,17 +66,18 @@
[(quote q) null]
[(quote-syntax q) null]
[(#%plain-lambda formals expr ...)
;; FIXME: this case makes the algorithm quadratic-time
(let ([free (merge (map free-vars (syntax->list #'(expr ...))))]
[bindings (formals->boundmap #'formals)])
(filter (lambda (id)
(not (bound-identifier-mapping-get bindings id (lambda () #f))))
free))]
[(case-lambda [formals expr ...] ...)
(merge (map free-vars (syntax->list
#'((#%plain-lambda formals expr ...) ...))))]
(map free-vars (syntax->list
#'((#%plain-lambda formals expr ...) ...)))]
[(let-values ([(id ...) rhs] ...) expr ...)
(merge (cons (free-vars #'(#%plain-lambda (id ... ...) expr ...))
(map free-vars (syntax->list #'(rhs ...)))))]
(cons (free-vars #'(#%plain-lambda (id ... ...) expr ...))
(map free-vars (syntax->list #'(rhs ...))))]
[(letrec-values ([(id ...) rhs] ...) expr ...)
(free-vars #'(#%plain-lambda (id ... ...) rhs ... expr ...))]
[(letrec-syntaxes+values stx-bindings ([(id ...) rhs] ...) expr ...)
@ -76,6 +86,6 @@
(ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%expression
#'#%variable-reference #'with-continuation-mark))
(merge (map free-vars (syntax->list #'(expr ...))))]
(map free-vars (syntax->list #'(expr ...)))]
[(kw . _)
(error 'free-vars "unknown core form: ~a" (syntax->datum #'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?)]{
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
@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))))))