lexical contexts broken

All the tests in the program at the end of this report should pass but
they're not.

(library (b bound)
   (export unbound-identifier?)
   (import
     (for (rnrs base)
          (meta 0))
     (for (rnrs syntax-case)
          (meta 0))
     (for (only (rnrs base) define)
          (meta -1))
     (for (only (rnrs syntax-case) syntax)
          (meta -1))
     (for (b ctxt)
          (meta -1) (meta 0))
     (for (b p-ctxt)
          (meta -1) (meta 0)))

   (define (unbound-identifier? x)
     (and (not (free-identifier=? x #'define))
          (not (free-identifier=? x #'syntax))
          (not (free-identifier=? x #'ctxt))
          (not (free-identifier=? x #'p-ctxt))
          (or (free-identifier=? x (datum->syntax ctxt (syntax->datum x)))
              (free-identifier=? x (datum->syntax p-ctxt (syntax->datum
x)))))))

(library (b ctxt)
   (export ctxt)
   (import (for (only (rnrs base) define)
                (meta -1) (meta 0))
           (for (only (rnrs syntax-case) syntax)
                (meta -1) (meta 0)))
   (define ctxt #'here))

(library (b p-ctxt)
   (export p-ctxt)
   (import (for (prefix (only (rnrs base) define) p-)
                (meta -1) (meta 0))
           (for (prefix (only (rnrs syntax-case) syntax) p-)
                (meta -1) (meta 0)))
   (p-define p-ctxt (p-syntax here)))

The below program exposes the bug(s):

(import
  (for (except (rnrs base) define)
       (meta 0))
  (for (prefix (only (rnrs base) define) rnrs:)
       (meta 0))
  (for (only (rnrs base) lambda not)
       (meta 1))
  (for (only (rnrs io simple) display)
       (meta 0))
  (for (except (rnrs syntax-case) syntax)
       (meta 1))
  (for (prefix (only (rnrs syntax-case) syntax) rnrs:)
       (meta 0) (meta 1))
  (for (b bound)
       (meta 1))
  (for (b ctxt)
       (meta 0))
  (for (b p-ctxt)
       (meta 0)))

(define-syntax test
  (lambda (stx)
    (syntax-case stx ()
      ((_ id bool)
       (with-syntax ((bound? (not (unbound-identifier? (rnrs:syntax id)))))
         (rnrs:syntax
          (begin
            (display 'id) (display " => ")
            (display (if bound? "bound " "unbound "))
            (display (if (boolean=? bound? bool) "(pass)\n" "(FAIL)\n")))))))))

(test list #T)
(test foobar #F)
(let ((foobar 1))
  (test foobar #T))

(test rnrs:define #T)
(test rnrs:syntax #T)
(test ctxt #T)
(test p-ctxt #T)

(test define #F)
(test syntax #F)

(let ((define 1)
      (syntax 1))
  (test define #T)
  (test syntax #T))

(test p-define #F)
(test p-syntax #F)

(let ((p-define 1)
      (p-syntax 1))
  (test p-define #T)
  (test p-syntax #T))

% ypsilon --sitelib . --r6rs b/bound-tests.sps 
list => unbound (FAIL)
foobar => unbound (pass)
foobar => bound (pass)
rnrs:define => bound (pass)
rnrs:syntax => bound (pass)
ctxt => bound (pass)
p-ctxt => bound (pass)
define => bound (FAIL)
syntax => bound (FAIL)
define => bound (pass)
syntax => bound (pass)
p-define => unbound (pass)
p-syntax => unbound (pass)
p-define => bound (pass)
p-syntax => bound (pass)
%
Original issue reported on code.google.com by derick.e...@gmail.com on 20 Jun 2009 at 3:09
SapphireDensetsu / ypsilon

lexical contexts broken #106
