Ticket #445: fix-canonicalize-body.patch

File fix-canonicalize-body.patch, 3.8 KB (added by sjamaan, 14 years ago)
  • expand.scm

    diff --git a/expand.scm b/expand.scm
    index 443c1c4..dca57a8 100644
    a b  
    444444
    445445(define ##sys#canonicalize-body
    446446  (lambda (body #!optional (se (##sys#current-environment)) cs?)
     447    (define (canonical-core-macro-name renamed)
     448      (let ((macro (or (lookup renamed se) renamed)))
     449        (if (not (pair? macro))
     450            macro ; Not found in SE?  Already a canonical name or not a macro
     451            (let find-macro ((handler (cadr macro))
     452                             (bindings (##sys#macro-environment)))
     453              (if (null? bindings)
     454                  #f
     455                  (if (eq? (caddar bindings) handler)
     456                      (caar bindings)
     457                      (find-macro handler (cdr bindings))))))))
    447458    (define (fini vars vals mvars mvals body)
    448459      (if (and (null? vars) (null? mvars))
    449460          (let loop ([body2 body] [exps '()])
     
    451462                (cons
    452463                 '##core#begin
    453464                 body) ; no more defines, otherwise we would have called `expand'
    454                 (let ([x (car body2)])
    455                   (if (and (pair? x)
    456                            (let ((d (car x)))
    457                              (and (symbol? d)
    458                                   (or (eq? (or (lookup d se) d) 'define)
    459                                       (eq? (or (lookup d se) d) 'define-values)))) )
    460                       (cons
     465                (let* ([x (car body2)]
     466                       [m (and (pair? x) (symbol? (car x))
     467                               (canonical-core-macro-name (car x)))])
     468                  (if (or (eq? m 'define) (eq? m 'define-values))
     469                      (cons
    461470                       '##core#begin
    462471                       (##sys#append (reverse exps) (list (expand body2))))
    463472                      (loop (cdr body2) (cons x exps)) ) ) ) )
     
    492501               ((and (list? (car body))
    493502                     (>= 3 (length (car body)))
    494503                     (symbol? (caar body))
    495                      (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
     504                     (eq? 'define-syntax (canonical-core-macro-name (caar body))))
    496505                (let ((def (car body)))
    497506                  (loop
    498507                   (cdr body)
     
    514523            (fini vars vals mvars mvals body)
    515524            (let* ((x (car body))
    516525                   (rest (cdr body))
    517                    (exp1 (and (pair? x) (car x)))
    518                    (head (and exp1
    519                               (symbol? exp1)
    520                               (or (lookup exp1 se) exp1))))
    521               (if (not (symbol? head))
     526                   (exp1 (and (pair? x) (car x))))
     527              (if (not (symbol? exp1))
    522528                  (fini vars vals mvars mvals body)
    523                   (case head
     529                  (case (canonical-core-macro-name exp1)
    524530                    ((define)
    525531                     (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
    526532                     (let loop2 ([x x])
     
    558564                    ((##core#begin)
    559565                     (loop (##sys#append (cdr x) rest) vars vals mvars mvals) )
    560566                    (else
    561                      (if (or (memq head vars) (memq head mvars))
     567                     (if (or (memq exp1 vars) (memq exp1 mvars))
    562568                         (fini vars vals mvars mvals body)
    563569                         (let ((x2 (##sys#expand-0 x se cs?)))
    564570                           (if (eq? x x2)
  • tests/syntax-tests.scm

    diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
    index e011487..60ebf7a 100644
    a b  
    713713       (map (cute + (begin (set! a (+ a 1)) a) <>)
    714714            '(1 2))
    715715       a))
    716 (f (eval '((cute + <...> 1) 1)))
    717  No newline at end of file
     716(f (eval '((cute + <...> 1) 1)))
     717
     718;; Let's internal defines properly compared to core define procedure when renamed
     719(f (eval '(let-syntax ((foo (syntax-rules () ((_ x) (begin (define x 1))))))
     720            (let () (foo a))
     721            (print "1: " a))))
     722
     723(t '(a 1) (letrec-syntax ((define (syntax-rules () ((_ x y) (list 'x y))))
     724                          (foo (syntax-rules () ((_ x) (define x 1)))))
     725            (let () (foo a))))
     726
     727(t '(1) (let-syntax ((define (syntax-rules () ((_ x) (list x)))))
     728          (let () (define 1))))
     729
     730;; Local override: not a macro
     731(t '(1) (let ((define list)) (define 1)))
     732
     733;; Toplevel (no SE)
     734(define-syntax foo (syntax-rules () ((_ x) (begin (define x 1)))))
     735(foo a)
     736(t 1 a)