syntax/free-vars: deterministic result order

Closes PR 12798

collects/syntax/free-vars.rkt

@@ -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? t) a]
-    [(null? (cdr l)) (car l)]
+      [(identifier? t)
-    [else (let ([m (make-module-identifier-mapping)])
+       (if (module-identifier-mapping-get m t (lambda () #f))
-            (for-each (lambda (ids)
+           a
-                        (for-each (lambda (id)
+           (begin
-                                    (module-identifier-mapping-put! m id #t))
+             (module-identifier-mapping-put! m t #t)
-                                  ids))
+             (cons t a)))]
-                      l)
+      [(pair? t) (loop (cdr t) (loop (car t) a))]
-            (module-identifier-mapping-map m (lambda (k v) k)))]))
+      [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
+        (map free-vars (syntax->list
-                              #'((#%plain-lambda formals expr ...) ...))))]
+                        #'((#%plain-lambda formals expr ...) ...)))]
        [(let-values ([(id ...) rhs] ...) expr ...)
-       (merge (cons (free-vars #'(#%plain-lambda (id ... ...) expr ...))
+        (cons (free-vars #'(#%plain-lambda (id ... ...) expr ...))
-                    (map free-vars (syntax->list #'(rhs ...)))))]
+              (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))]))))

collects/syntax/scribblings/free-vars.scrbl

@@ -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]).
 

collects/tests/syntax/free-vars.rkt

@@ -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))))))