[plt-scheme] to define, or to let

Out of curiosity, I wrote a little script (below) to test how many
letrecs in our CVS repository have "unprotected" references to
letrec-bound variables. The script takes advantage of the fact that
fully expanded mzscheme code still contains letrec (technically,
letrec-values).

Surprisingly, only 1 of the 1221 letrecs has such an unprotected
reference; here it is (from plt/collects/algol60/runtime.ss):

   (define undefined (letrec ([x x]) x))

This does count internal definitions (since they expand to letrec) but
not units (they expand directly to lets+set!s) or modules (their
top-levels stays as definitions). If units and modules were counted,
there would probably be many more.

Robby

;; below, "bad" letrecs are those that don't pass the syntactic
;; test and "good" ones are ones that do pass the syntactic test.

;; letrecs : number
;; total count of letrecs
(define letrecs 0)

;; failed-test : number
;; total count of "bad" letrecs
(define failed-test 0)

;; process-directory : string[directory] -> void
;; recursively traverses `dir' and all its subdirectories,
;; looking for files to send to process-file.
(define (process-directory dir)
  (for-each
   (lambda (file)
     (let ([c (build-path dir file)])
       (cond
         [(file-exists? c) (process-file dir c)]
         [(directory-exists? c) (process-directory c)]
         [else (void)])))
   (directory-list dir)))

;; process-file : string[directory] string[filename] -> void
;; prints the name of the file before processing it
;; prints the current total letrec count and
;; the total count of "bad" letrecs after processing the file
(define (process-file dir filename)
  (printf "testing ~s\n" filename)
  (find-letrec
   (with-handlers ([not-break-exn? (lambda (x) (void))])
     (parameterize ([current-load-relative-directory dir]
                    [current-directory dir])
       (expand 
        (call-with-input-file filename
          (lambda (port)
            (read-syntax filename port)))))))
  (printf "letrecs ~s failed test ~s\n" letrecs failed-test))

;; find-letrec : stx -> void
;; finds all of the letrecs in some syntax
(define (find-letrec stx)
  (let loop ([stx stx])
    (syntax-case stx (letrec)
      [(letrec-values (((x ...) rhs) ...) body ...)
       (set! letrecs (+ letrecs 1))
       (unless (found-one (syntax (((x ...) rhs) ...)))
         (set! failed-test (+ failed-test 1)))]
      [(x ...)
       (for-each loop (syntax->list (syntax (x ...))))]
      [else (void)])))

;; found-one : stx[letrec, binders section] -> boolean
;; called to inspect a letrec
;; returns #t to indicate the letrec is "good" and #f for "bad"
(define (found-one stxs)
  (syntax-case stxs ()
    [([(x ...) rhs] ...)
     (let ([vars (apply append (map syntax->list (syntax->list (syntax ((x ...) ...)))))])
       (let/ec fail
         (for-each (lambda (rhs) (explore-rhs rhs vars (lambda () (fail #f))))
                   (syntax->list (syntax (rhs ...))))
         #t))]))

;; explore-rhs : stx (listof identifer) (-> void) -> void
;; bad-var escapes
;; looks for a variable in rhs that is module-identifier=? to one of vars
;; if found, calls `bad-var'. Otherwise, just returns
(define (explore-rhs rhs vars bad-var)
  (let loop ([stx rhs])
    (syntax-case rhs (lambda case-lambda)
      [(lambda . rest) (void)]
      [(case-lambda . rest) (void)]
      [(quote . rest) (void)]
      [(quote-syntax . rest) (void)]
      [(x ...) (for-each loop (syntax->list (syntax (x ...))))]
      [x 
       (identifier? (syntax x))
       (when (ormap (lambda (var) (module-identifier=? (syntax x) var))
                    vars)
         (bad-var))]
      [x (void)])))

;; get the ball rolling
(process-directory (current-directory))