fixing identifier comparison bugs

init.scm

@@ -124,11 +124,11 @@
      (if (null? (cdr expr))
          #f
          ((lambda (cl)
-            (if (compare 'else (car cl))
+            (if (compare (rename 'else) (car cl))
                 (if (pair? (cddr expr))
                     (error "non-final else in cond" expr)
                     (cons (rename 'begin) (cdr cl)))
-                (if (if (null? (cdr cl)) #t (compare '=> (cadr cl)))
+                (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
                     (list (list (rename 'lambda) (list (rename 'tmp))
                                 (list (rename 'if) (rename 'tmp)
                                       (if (null? (cdr cl))
@@ -169,20 +169,20 @@
        (cond
         ((pair? x)
          (cond
-          ((eq? 'unquote (car x))
+          ((compare (rename 'unquote) (car x))
            (if (<= d 0)
                (cadr x)
                (list (rename 'list) (list (rename 'quote) 'unquote)
                      (qq (cadr x) (- d 1)))))
-          ((eq? 'unquote-splicing (car x))
+          ((compare (rename 'unquote-splicing) (car x))
            (if (<= d 0)
                (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
                (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
                      (qq (cadr x) (- d 1)))))
-          ((eq? 'quasiquote (car x))
+          ((compare (rename 'quasiquote) (car x))
            (list (rename 'list) (list (rename 'quote) 'quasiquote)
                  (qq (cadr x) (+ d 1))))
-          ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x)))
+          ((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x)))
            (if (null? (cdr x))
                (cadar x)
                (list (rename 'append) (cadar x) (qq (cdr x) d))))
@@ -243,7 +243,7 @@
      (define (clause ls)
        (cond
         ((null? ls) #f)
-        ((compare 'else (caar ls))
+        ((compare (rename 'else) (caar ls))
          `(,(rename 'begin) ,@(cdar ls)))
         (else
          (if (and (pair? (caar ls)) (null? (cdaar ls)))
@@ -669,7 +669,7 @@
                ((null? p) (list _and (list _null? v) (k vars)))
                (else (list _and (list _equal? v p) (k vars))))))))
        (define (ellipse? x)
-         (and (pair? x) (pair? (cdr x)) (compare '... (cadr x))))
+         (and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x))))
        (define (ellipse-depth x)
          (if (ellipse? x)
              (+ 1 (ellipse-depth (cdr x)))

lib/chibi/loop/loop.scm

@@ -69,7 +69,7 @@
 ;;            (er-macro-transformer
 ;;             (lambda (expr rename compare)
 ;;               (receive (named posns)
-;;                   (partition (lambda (x) (and (list? x) (compare (car x) '=>)))
+;;                   (partition (lambda (x) (and (list? x) (compare (car x) (rename '=>))))
 ;;                              (cdr expr))
 ;;                 (let lp ((ls '((arg default) ...)) (posns posns) (args '()))
 ;;                   (cond

tests/r5rs-tests.scm

@@ -386,6 +386,21 @@
 
 (test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p))))
 
+(test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad))))
+
+(test 'ok (let ((=> 1)) (cond (#t => 'ok))))
+
+(test '(,foo) (let ((unquote 1)) `(,foo)))
+
+(test '(,@foo) (let ((unquote-splicing 1)) `(,@foo)))
+
+(test 'ok
+      (let ((... 2))
+        (let-syntax ((s (syntax-rules ()
+                          ((_ x ...) 'bad)
+                          ((_ . r) 'ok))))
+          (s a b c))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (test-report)