add tests for bound-identifier-comparator

3 files changed, 175 insertions, 121 deletions

diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index 9eae3b9..320ee6e 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -241,8 +241,9 @@
            (add-timestamps/same-wrap stx id location-to))))))
 
 (define (generate-unique-symbol)
-  ;; An actual implementation of this procedure would require implementation
-  ;; support.
+  ;; Tries as best as possible to generate a unique symbol. Not read/write
+  ;; invariant. An actual implementation of this procedure would require
+  ;; implementation support.
   (string->symbol
    (string-append "gensym."
                   (number->string
@@ -283,18 +284,27 @@
        (set=? (wrap->timestamps id1) (wrap->timestamps id2))))
 
 (define bound-identifier-comparator
-  (make-comparator
-   identifier?
-   bound-identifier=?
-   (lambda (id-1 id-2)
-     (if (<? environment-key-comparator (resolve id-1) (resolve id-2))
-         #t
-         (<? set-comparator
-             (wrap->timestamps id-1)
-             (wrap->timestamps id-2))))
-   (lambda (id)
-     (+ (comparator-hash set-comparator (wrap->timestamps id))
-        (comparator-hash environment-key-comparator (resolve id))))))
+  (let ((bound-identifier<?
+         (lambda (id1 id2)
+           (comparator-if<=> environment-key-comparator
+                             (resolve id1)
+                             (resolve id2)
+             #t
+             (<? set-comparator
+                 (wrap->timestamps id1)
+                 (wrap->timestamps id2))
+             #f)))
+        (bound-identifier-hash
+         (lambda (id)
+           (+ (comparator-hash set-comparator
+                               (wrap->timestamps id))
+              (comparator-hash environment-key-comparator
+                               (resolve id))))))
+    (make-comparator
+     identifier?
+     bound-identifier=?
+     bound-identifier<?
+     bound-identifier-hash)))
 
 (define (push-wrap stx expr)
   ;; Give `expr` the wrap of `stx`. This does not check that `stx` does
diff --git a/multisyntax/syntax-object.sld b/multisyntax/syntax-object.sld
index ab0ad15..7886d38 100644
--- a/multisyntax/syntax-object.sld
+++ b/multisyntax/syntax-object.sld
@@ -23,6 +23,7 @@
           lexical-location->string
           lexical-location-comparator
           environment-key-comparator
+          bound-identifier-comparator
           ;; Misc. predicates
           self-syntax? syntax?
           ;; Operations on wraps
diff --git a/test/syntax-object.scm b/test/syntax-object.scm
index fcd8215..674a675 100644
--- a/test/syntax-object.scm
+++ b/test/syntax-object.scm
@@ -16,117 +16,160 @@
 (define examples-of-self-syntax
   (list '() 1 #\a #f "a" #u8(1 2 3 4)))
 
-(define (test)
-  (test-group "locations"
-    (test-assert (comparator-test-type environment-key-comparator
+(define (test-locations)
+  (test-assert (comparator-test-type environment-key-comparator
                                        (generate-lexical-location 'test)))
-    (test-assert (comparator-test-type environment-key-comparator
+  (test-assert (comparator-test-type environment-key-comparator
                                        'test)))
-  (test-group "self-syntax?"
-    (for-each (lambda (x)
+
+(define (test-self-syntax)
+  (for-each (lambda (x)
                 (test-assert "example of self-syntax" (self-syntax? x)))
-              examples-of-self-syntax)
-    (test-assert "symbol is not self-syntax" (not (self-syntax? 'x)))
-    (test-assert "cons is not self-syntax" (not (self-syntax? (cons 1 2))))
-    (test-assert "vector is not self-syntax" (not (self-syntax? #(1 2)))))
-  (test-group "syntax?"
-    (for-each (lambda (x)
-                (test-assert "self-syntax is syntax" (syntax? x)))
-              examples-of-self-syntax)
-    (for-each (lambda (x)
-                (test-assert "wrap of self-syntax is syntax" (syntax? (empty-wrap x))))
-              examples-of-self-syntax)
-    (test-assert "list of self-syntax is syntax"
-                 (syntax? examples-of-self-syntax))
-    (test-assert "vector of self-syntax is syntax"
-                 (syntax? (list->vector examples-of-self-syntax)))
-    (test-assert "wrap of symbol is syntax"
-                 (syntax? (empty-wrap 'x))))
-  (test-group "identifier?"
-    (for-each (lambda (x)
-                (test-assert "self-syntax is not identifier"
-                             (not (identifier? x))))
-              examples-of-self-syntax)
-    (test-assert "wrap of symbol is identifier"
-                 (identifier? (empty-wrap 'x)))
-    (test-assert "wrap of list is not identifier"
-                 (not (identifier? (empty-wrap (list 'x))))))
-  (test-group "add-timestamp"
-    (test-assert "timestamps are unique"
-                 (not (equal? (generate-timestamp) (generate-timestamp))))
-    (let ((ts (generate-timestamp))
-          (id (empty-wrap 'test)))
-      (test-assert "empty wrap has no timestamps"
-                   (set-empty? (wrap->timestamps id)))
+            examples-of-self-syntax)
+  (test-assert "symbol is not self-syntax" (not (self-syntax? 'x)))
+  (test-assert "cons is not self-syntax" (not (self-syntax? (cons 1 2))))
+  (test-assert "vector is not self-syntax" (not (self-syntax? #(1 2)))))
+
+(define (test-syntax-predicate)
+  (for-each (lambda (x)
+              (test-assert "self-syntax is syntax" (syntax? x)))
+            examples-of-self-syntax)
+  (for-each (lambda (x)
+              (test-assert "wrap of self-syntax is syntax" (syntax? (empty-wrap x))))
+            examples-of-self-syntax)
+  (test-assert "list of self-syntax is syntax"
+               (syntax? examples-of-self-syntax))
+  (test-assert "vector of self-syntax is syntax"
+               (syntax? (list->vector examples-of-self-syntax)))
+  (test-assert "wrap of symbol is syntax"
+               (syntax? (empty-wrap 'x))))
+
+(define (test-identifier-predicate)
+  (for-each (lambda (x)
+              (test-assert "self-syntax is not identifier"
+                           (not (identifier? x))))
+            examples-of-self-syntax)
+  (test-assert "wrap of symbol is identifier"
+               (identifier? (empty-wrap 'x)))
+  (test-assert "wrap of list is not identifier"
+               (not (identifier? (empty-wrap (list 'x))))))
+
+(define (test-add-timestamp)
+  (test-assert "timestamps are unique"
+               (not (equal? (generate-timestamp) (generate-timestamp))))
+  (let ((ts (generate-timestamp))
+        (id (empty-wrap 'test)))
+    (test-assert "empty wrap has no timestamps"
+                 (set-empty? (wrap->timestamps id)))
+    (set! id (add-timestamp id ts))
+    (test-equal "adding a timestamp adds that timestamp"
+                (list ts)
+                (set->list (wrap->timestamps id)))
+    (set! id (add-timestamp id ts))
+    (test-assert "adding the same timestamp removes the timestamp"
+                 (set-empty? (wrap->timestamps id)))
+    (let ((new-ts (generate-timestamp)))
       (set! id (add-timestamp id ts))
-      (test-equal "adding a timestamp adds that timestamp"
+      (set! id (add-timestamp id new-ts))
+      (test-assert "adding one timestamp makes the wrap contain that timestamp"
+                   (set-contains? (wrap->timestamps id) ts))
+      (test-assert "adding another timestamp makes the wrap contain that timestamp"
+                   (set-contains? (wrap->timestamps id) new-ts))
+      (test-equal "only two timestamps were added"
+                  (set-size (wrap->timestamps id))
+                  2)
+      (set! id (add-timestamp id new-ts))
+      (test-equal "adding one timestamp removes one and keeps the other"
                   (list ts)
-                  (set->list (wrap->timestamps id)))
-      (set! id (add-timestamp id ts))
-      (test-assert "adding the same timestamp removes the timestamp"
-                   (set-empty? (wrap->timestamps id)))
-      (let ((new-ts (generate-timestamp)))
-        (set! id (add-timestamp id ts))
-        (set! id (add-timestamp id new-ts))
-        (test-assert "adding one timestamp makes the wrap contain that timestamp"
-                     (set-contains? (wrap->timestamps id) ts))
-        (test-assert "adding another timestamp makes the wrap contain that timestamp"
-                     (set-contains? (wrap->timestamps id) new-ts))
-        (test-equal "only two timestamps were added"
-                    (set-size (wrap->timestamps id))
-                    2)
-        (set! id (add-timestamp id new-ts))
-        (test-equal "adding one timestamp removes one and keeps the other"
-                    (list ts)
-                    (set->list (wrap->timestamps id))))))
+                  (set->list (wrap->timestamps id))))))
+
+(define (test-add-substitution)
+  (test-group "no timestamps"
+    (let* ((newloc (generate-lexical-location 'test))
+           (stx (add-substitution (empty-wrap 'test)
+                                  (empty-wrap 'test)
+                                  newloc)))
+      (test-assert (=? lexical-location-comparator
+                       newloc
+                       (resolve stx)))))
+  (test-group "mismatched timestamps"
+    (let* ((newloc (generate-lexical-location 'test))
+           (stx (add-substitution (add-timestamp (empty-wrap 'test)
+                                                 (generate-timestamp))
+                                  (empty-wrap 'test)
+                                  newloc)))
+      (test-assert (=? environment-key-comparator
+                       'test
+                       (resolve stx)))))
+  (test-group "mismatched resolved name"
+    (let* ((newloc (generate-lexical-location 'test))
+           (stx (add-substitution (empty-wrap 'test)
+                                  (empty-wrap 'test2)
+                                  newloc)))
+      (test-assert (=? environment-key-comparator
+                       'test
+                       (resolve stx)))))
+  (test-group "multiple names in environment"
+    (let* ((loc1 (generate-lexical-location 'test1))
+           (loc2 (generate-lexical-location 'test2))
+           (stx (add-substitution (empty-wrap 'test)
+                                  (empty-wrap 'test)
+                                  loc1))
+           (stx (add-substitution stx
+                                  (empty-wrap 'test2)
+                                  loc2)))
+      (test-assert (=? environment-key-comparator
+                       (resolve stx)
+                       loc1))))
+  (test-group "intermediate substitutions"
+    (let* ((loc1 (generate-lexical-location 'test1))
+           (loc2 (generate-lexical-location 'test2))
+           (stx (add-substitution (empty-wrap 'test)
+                                  (empty-wrap 'test)
+                                  loc1))
+           (stx (add-substitution stx stx loc2)))
+      (test-assert (=? environment-key-comparator
+                       (resolve stx)
+                       loc2)))))
+
+(define (test-bound-identifier-comparator)
+  (define ids
+    (let* ((ts (generate-timestamp))
+           (id-x (empty-wrap 'x))
+           (id-y (empty-wrap 'y))
+           (mark-x (add-timestamp id-x ts))
+           (loc1 (generate-lexical-location 'test1))
+           (subst-on-x (add-substitution id-x
+                                         id-x
+                                         loc1))
+           (subst-on-mark-x (add-substitution id-x
+                                              id-x
+                                              loc1)))
+      (list
+       id-x
+       id-y
+       mark-x
+       (add-timestamp (empty-wrap 'x)
+                      (generate-timestamp))
+       (add-timestamp (empty-wrap 'y) ts)
+       (empty-wrap 'z)
+       subst-on-x
+       subst-on-mark-x)))
+  (define the-set (list->set bound-identifier-comparator ids))
+  (for-each (lambda (id)
+              (test-assert (bound-identifier=?
+                            id
+                            (set-member the-set id #f))))
+            ids))
+
+(define (test)
+  (test-group "locations" (test-locations))
+  (test-group "self-syntax?" (test-self-syntax))
+  (test-group "syntax?" (test-syntax-predicate))
+  (test-group "identifier?" (test-identifier-predicate))
+  (test-group "add-timestamp" (test-add-timestamp))
   (test-group "resolve a symbol"
     (test-eq (resolve (empty-wrap 'test)) 'test))
-  (test-group "add-substitution"
-    (test-group "no timestamps"
-      (let* ((newloc (generate-lexical-location 'test))
-             (stx (add-substitution (empty-wrap 'test)
-                                    (empty-wrap 'test)
-                                    newloc)))
-        (test-assert (=? lexical-location-comparator
-                         newloc
-                         (resolve stx)))))
-    (test-group "mismatched timestamps"
-      (let* ((newloc (generate-lexical-location 'test))
-             (stx (add-substitution (add-timestamp (empty-wrap 'test)
-                                                   (generate-timestamp))
-                                    (empty-wrap 'test)
-                                    newloc)))
-        (test-assert (=? environment-key-comparator
-                         'test
-                         (resolve stx)))))
-    (test-group "mismatched resolved name"
-      (let* ((newloc (generate-lexical-location 'test))
-             (stx (add-substitution (empty-wrap 'test)
-                                    (empty-wrap 'test2)
-                                    newloc)))
-        (test-assert (=? environment-key-comparator
-                         'test
-                         (resolve stx)))))
-    (test-group "multiple names in environment"
-      (let* ((loc1 (generate-lexical-location 'test1))
-             (loc2 (generate-lexical-location 'test2))
-             (stx (add-substitution (empty-wrap 'test)
-                                    (empty-wrap 'test)
-                                    loc1))
-             (stx (add-substitution stx
-                                    (empty-wrap 'test2)
-                                    loc2)))
-        (test-assert (=? environment-key-comparator
-                         (resolve stx)
-                         loc1))))
-    (test-group "intermediate substitutions"
-      (let* ((loc1 (generate-lexical-location 'test1))
-             (loc2 (generate-lexical-location 'test2))
-             (stx (add-substitution (empty-wrap 'test)
-                                    (empty-wrap 'test)
-                                    loc1))
-             (stx (add-substitution stx stx loc2)))
-        (test-assert (=? environment-key-comparator
-                         (resolve stx)
-                         loc2))))))
-
+  (test-group "add-substitution" (test-add-substitution))
+  (test-group "bound-identifier-comparator"
+    (test-bound-identifier-comparator)))