move rewriters to implementation file, make rewriter cycle-detecting

19 files changed, 158 insertions, 143 deletions

diff --git a/README.md b/README.md
index dfe3187..34ce366 100644
--- a/README.md
+++ b/README.md
@@ -16,10 +16,7 @@ that can do cycle detection.
 Cuprate supports TR7, CHICKEN-5, Foment, Chibi, SKINT, Gauche, and
 Sagittarius. STKLOS, Mosh, Chez, Guile, Racket, and Loko support soon.
 
-TODO: Allow for (conceptually) delimited continuations to be captured and
-reinstated even if they are made in a different test group / assertion.
-The continuation's test-info will be the test-info at the time of capture.
-Returning through the same group/assertion twice will raise an exception.
+TODO: Simplify repeated code in implementation subdir
 
 ## API
 
diff --git a/cuprate.egg b/cuprate.egg
index 669ddaf..a5035c9 100644
--- a/cuprate.egg
+++ b/cuprate.egg
@@ -7,16 +7,13 @@
  (components (extension cuprate
                (source "lib/cuprate.sld")
                (source-dependencies "lib/cuprate-impl.scm" "lib/cuprate.simple-define-test-application.scm")
-               (component-dependencies cuprate.rewriters cuprate.implementation.chicken)
+               (component-dependencies cuprate.implementation)
                (csc-options "-R" "r7rs" "-X" "r7rs"))
              (extension cuprate.implementation.chicken
                (source "lib/cuprate/implementation/chicken.sld")
                (csc-options "-R" "r7rs" "-X" "r7rs"))
-             (extension cuprate.rewriters
-               (source "lib/cuprate/rewriters.sld")
-               (component-dependencies cuprate.rewriters.chicken)
+             (extension cuprate.implementation
+               (source "lib/cuprate/implementation.sld")
+               (component-dependencies cuprate.implementation.chicken)
                (csc-options "-R" "r7rs" "-X" "r7rs"))
-             (extension cuprate.rewriters.chicken
-               (source "lib/cuprate/rewriters/chicken.sld")
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
-               )))
+               ))
diff --git a/lib/cuprate-impl.scm b/lib/cuprate-impl.scm
index dec3959..7140ecc 100644
--- a/lib/cuprate-impl.scm
+++ b/lib/cuprate-impl.scm
@@ -263,6 +263,13 @@
          (test-ref 'name-stack)
          (rewrite ex)))
 
+;;; ;;;;;;;;;;;;
+;;; Default rewriters
+;;; ;;;;;;;;;;;;
+
+(define (rewrite obj)
+  (rewrite-enter (test-ref 'rewriters) obj))
+
 ;;; ;;;;;;;;;;;;;;;;
 ;;; test info
 ;;; ;;;;;;;;;;;;;;;;
@@ -294,6 +301,7 @@
      (name-stack . ())
      (never-print-dto . ,default-test-dto)
      (pretty-print . ,pretty-print)
+     (rewriters . ,default-rewriters)
      (never-print . ,(alist->default-dictionary
                       (map (lambda (x) (cons x x))
                            '(skip-test? when-test-skipped before-test! setup-test!
diff --git a/lib/cuprate.sld b/lib/cuprate.sld
index 05d9bf6..a393e78 100644
--- a/lib/cuprate.sld
+++ b/lib/cuprate.sld
@@ -1,6 +1,6 @@
 (define-library (cuprate)
   (import (scheme base) (scheme write) (scheme process-context) (srfi 225)
-          (cuprate rewriters))
+          (cuprate implementation))
   (export   ;; test info
    test-info test-info? modify-test-info! inspect-test-info
    test-info-dict test-dto default-test-info-dict default-test-dto
@@ -28,16 +28,7 @@
    test-skip-all
    test-group
    with-test-group-cleanup
-   test-exit
-   pretty-print)
-  (cond-expand
-    (chicken-5 (import (cuprate implementation chicken)))
-    (gauche (import (cuprate implementation gauche)))
-    (foment (import (cuprate implementation foment)))
-    (chibi (import (cuprate implementation chibi)))
-    (skint (import (cuprate implementation skint)))
-    (sagittarius (import (cuprate implementation sagittarius)))
-    (else (import (cuprate implementation r7rs))))
+   test-exit rewrite)
   (begin
     (define-record-type <test-info>
       (wrap-test-info dict exited?)
diff --git a/lib/cuprate/implementation.sld b/lib/cuprate/implementation.sld
new file mode 100644
index 0000000..61849c1
--- /dev/null
+++ b/lib/cuprate/implementation.sld
@@ -0,0 +1,45 @@
+(define-library (cuprate implementation)
+  (import (scheme base))
+  (cond-expand
+    (chicken-5 (import (cuprate implementation chicken)))
+    (gauche (import (cuprate implementation gauche)))
+    (foment (import (cuprate implementation foment)))
+    (chibi (import (cuprate implementation chibi)))
+    (skint (import (cuprate implementation skint)))
+    (sagittarius (import (cuprate implementation sagittarius)))
+    (else (import (cuprate implementation r7rs))))
+  (export default-rewriters rewrite-enter pretty-print
+          alist->default-dictionary default-test-dto)
+  (begin
+    (define (default-on-pair rewrite pair)
+      (cons (rewrite (car pair)) (rewrite (cdr pair))))
+    (define (default-on-vector rewrite vec)
+      (vector-map rewrite vec))
+    (define (default-on-error rewrite eobj)
+      `(error ,(rewrite (error-object-message eobj))
+              ,@(map rewrite (error-object-irritants eobj))))
+    (define default-rewriters
+      (append implementation-rewriters
+              (list (cons pair? default-on-pair)
+                    (cons vector? default-on-vector)
+                    (cons error-object? default-on-error))))
+    (define (rewrite-enter rewriters obj)
+      (letrec ((eq-map (make-eq-map))
+               (rewrite
+                (lambda (obj)
+                  (if (eq-map 'contains? obj)
+                      (eq-map 'cycle-counter obj)
+                      (begin
+                        (eq-map 'intern! obj)
+                        (let loop ((rewriters rewriters))
+                          (cond
+                            ((null? rewriters) obj)
+                            (((caar rewriters) obj)
+                             (let ((new-obj ((cdar rewriters) rewrite obj)))
+                               (if (eq-map 'cycle-used? obj)
+                                   (list (eq-map 'cycle-counter)
+                                         '=
+                                         new-obj)
+                                   new-obj)))
+                            (else (loop (cdr rewriters))))))))))
+        (rewrite obj)))))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/alist-eq-map.scm b/lib/cuprate/implementation/alist-eq-map.scm
new file mode 100644
index 0000000..f9841e7
--- /dev/null
+++ b/lib/cuprate/implementation/alist-eq-map.scm
@@ -0,0 +1,21 @@
+(define (make-eq-map)
+  (define alist '())
+  (define interned-alist '())
+  (define counter 0)
+  (lambda (msg obj)
+    (case msg
+      ((contains?) (assq obj alist))
+      ((cycle-counter)
+       (set! interned-alist (cons obj interned-alist))
+       (let ((num (cdr (assq obj alist))))
+         (string->symbol (string-append
+                          "#"
+                          (number->string num)
+                          "#"))))
+      ((cycle-used?) (memq obj interned-alist))
+      ((intern!)
+       (set! alist (cons (cons obj counter) alist))
+       (set! counter (+ counter 1)))
+      (else (error 'make-eq-map
+                   "invalid message"
+                   msg)))))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/chibi.sld b/lib/cuprate/implementation/chibi.sld
index 318ac78..327568b 100644
--- a/lib/cuprate/implementation/chibi.sld
+++ b/lib/cuprate/implementation/chibi.sld
@@ -1,9 +1,13 @@
 (define-library (cuprate implementation chibi)
-  (import (scheme base) (srfi 166) (srfi 225))
+  (import (scheme base) (srfi 125) (srfi 166) (srfi 225)
+          (srfi 128))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "srfi-125-eq-map.scm")
   (begin
     (define (pretty-print obj)
       (show #t (pretty obj)))
     (define default-test-dto eqv-alist-dto)
-    (define (alist->default-dictionary x) x)))
\ No newline at end of file
+    (define (alist->default-dictionary x) x)
+    (define implementation-rewriters '())))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/chicken.sld b/lib/cuprate/implementation/chicken.sld
index a9bff2d..f3a0be0 100644
--- a/lib/cuprate/implementation/chicken.sld
+++ b/lib/cuprate/implementation/chicken.sld
@@ -1,9 +1,17 @@
 (define-library (cuprate implementation chicken)
   (import (scheme base) (chicken pretty-print)
-          (srfi 128) (srfi 146 hash) (srfi 225))
+          (srfi 128) (srfi 146 hash) (srfi 225)
+          (chicken memory representation)
+          (chicken condition))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "alist-eq-map.scm")
   (begin
     (define default-test-dto hash-mapping-dto)
     (define (alist->default-dictionary x)
-      (alist->hashmap (make-default-comparator) x))))
\ No newline at end of file
+      (alist->hashmap (make-default-comparator) x))
+    (define (default-on-condition rewrite cond)
+      (map rewrite (condition->list cond)))
+    (define implementation-rewriters
+      (list (cons condition? default-on-condition)))))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/foment.sld b/lib/cuprate/implementation/foment.sld
index 2ad53dc..907decd 100644
--- a/lib/cuprate/implementation/foment.sld
+++ b/lib/cuprate/implementation/foment.sld
@@ -1,10 +1,22 @@
 (define-library (cuprate implementation foment)
-  (import (scheme base) (srfi 166) (srfi 225))
+  (import (foment base) (scheme base) (srfi 166) (srfi 225) (srfi 128) (srfi 125))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "srfi-125-eq-map.scm")
   (begin
     (define (pretty-print obj)
       (show #t (pretty obj))
       (newline))
     (define default-test-dto eqv-alist-dto)
-    (define (alist->default-dictionary x) x)))
\ No newline at end of file
+    (define (alist->default-dictionary x) x)
+    (define (default-on-error rewrite error)
+      (let ((msg (error-object-message error))
+            (irritants (error-object-irritants error)))
+        `(error (type ,(rewrite (error-object-type error)))
+                (who ,(rewrite (error-object-who error)))
+                (kind ,(rewrite (error-object-kind error)))
+                (msg ,(rewrite (error-object-message error)))
+                (irritants ,@(map rewrite (error-object-irritants error))))))
+    (define implementation-rewriters
+      (list (cons error-object? default-on-error)))))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/gauche.sld b/lib/cuprate/implementation/gauche.sld
index 627ff5c..f057527 100644
--- a/lib/cuprate/implementation/gauche.sld
+++ b/lib/cuprate/implementation/gauche.sld
@@ -1,9 +1,13 @@
 (define-library (cuprate implementation gauche)
-  (import (scheme base) (scheme show) (srfi 225))
+  (import (scheme base) (scheme show) (srfi 225) (scheme hash-table)
+          (scheme comparator))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "srfi-125-eq-map.scm")
   (begin
     (define (pretty-print obj)
       (show #t (pretty obj)))
     (define default-test-dto eqv-alist-dto)
-    (define (alist->default-dictionary x) x)))
\ No newline at end of file
+    (define (alist->default-dictionary x) x)
+    (define implementation-rewriters '())))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/r7rs.sld b/lib/cuprate/implementation/r7rs.sld
index 0a1286f..8bfc84b 100644
--- a/lib/cuprate/implementation/r7rs.sld
+++ b/lib/cuprate/implementation/r7rs.sld
@@ -1,10 +1,13 @@
 (define-library (cuprate implementation r7rs)
   (import (scheme base) (scheme write) (srfi 225))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "alist-eq-map.scm")
   (begin
     (define (pretty-print obj)
       (write obj)
       (newline))
     (define default-test-dto eqv-alist-dto)
-    (define (alist->default-dictionary x) x)))
\ No newline at end of file
+    (define (alist->default-dictionary x) x)
+    (define implementation-rewriters '())))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/sagittarius.sld b/lib/cuprate/implementation/sagittarius.sld
index ba630f0..64ea883 100644
--- a/lib/cuprate/implementation/sagittarius.sld
+++ b/lib/cuprate/implementation/sagittarius.sld
@@ -1,10 +1,14 @@
 (define-library (cuprate implementation sagittarius)
-  (import (scheme base) (scheme format) (srfi 146 hash) (srfi 225))
+  (import (scheme base) (scheme format) (srfi 146 hash) (srfi 225)
+          (scheme hash-table) (scheme comparator))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "srfi-125-eq-map.scm")
   (begin
     (define (pretty-print obj)
-      (show #t (pretty obj))))
+      (show #t (pretty obj)))
+    (define implementation-rewriters '()))
   (cond-expand
     ;; Sagittarius has SRFI-146 hashmaps. If the full SRFI-225 is loaded
     ;; (which is hackily checked by checking if micro-srfi-225 is NOT
diff --git a/lib/cuprate/implementation/skint.sld b/lib/cuprate/implementation/skint.sld
index b2ce921..5ecf314 100644
--- a/lib/cuprate/implementation/skint.sld
+++ b/lib/cuprate/implementation/skint.sld
@@ -1,13 +1,15 @@
 (define-library (cuprate implementation skint)
   (import (scheme base) (srfi 128) (srfi 146 hash) (scheme write)
-          (srfi 225)
-          )
+          (srfi 225))
   (export pretty-print default-test-dto
-          alist->default-dictionary)
+          alist->default-dictionary
+          make-eq-map implementation-rewriters)
+  (include "alist-eq-map.scm")
   (begin
     (define (pretty-print obj)
       (write obj)
       (newline))
     (define default-test-dto hash-mapping-dto)
     (define (alist->default-dictionary x)
-      (alist->hashmap (make-default-comparator) x))))
\ No newline at end of file
+      (alist->hashmap (make-default-comparator) x))
+    (define implementation-rewriters '())))
\ No newline at end of file
diff --git a/lib/cuprate/implementation/srfi-125-eq-map.scm b/lib/cuprate/implementation/srfi-125-eq-map.scm
new file mode 100644
index 0000000..3a1d7b9
--- /dev/null
+++ b/lib/cuprate/implementation/srfi-125-eq-map.scm
@@ -0,0 +1,17 @@
+(define (make-eq-map)
+  (define counter-table (make-hash-table (make-eq-comparator)))
+  (define used-table (make-hash-table (make-eq-comparator)))
+  (define counter 0)
+  (lambda (msg obj)
+    (case msg
+      ((contains?) (hash-table-contains? counter-table obj))
+      ((cycle-counter) (let ((num (hash-table-ref counter-table obj)))
+                         (hash-table-set! used-table obj #t)
+                         (string->symbol
+                          (string-append "#"
+                                         (number->string num)
+                                         "#"))))
+      ((cycle-used?) (hash-table-contains? used-table obj))
+      ((intern!) (hash-table-set! counter-table obj counter)
+                 (set! counter (+ counter 1)))
+      (else (error "invalid message" msg)))))
\ No newline at end of file
diff --git a/lib/cuprate/rewriters.sld b/lib/cuprate/rewriters.sld
deleted file mode 100644
index a375cc8..0000000
--- a/lib/cuprate/rewriters.sld
+++ /dev/null
@@ -1,7 +0,0 @@
-(define-library (cuprate rewriters)
-  (import (scheme base))
-  (export rewriters rewrite)
-  (cond-expand
-    (chicken-5 (import (cuprate rewriters chicken)))
-    (foment (import (cuprate rewriters foment)))
-    (else (import (cuprate rewriters r7rs)))))
\ No newline at end of file
diff --git a/lib/cuprate/rewriters/chicken.sld b/lib/cuprate/rewriters/chicken.sld
deleted file mode 100644
index f92f998..0000000
--- a/lib/cuprate/rewriters/chicken.sld
+++ /dev/null
@@ -1,35 +0,0 @@
-(define-library (cuprate rewriters chicken)
-  (import (scheme base) (scheme write)
-          (chicken memory representation)
-          (chicken condition))
-  (export rewriters rewrite)
-  (begin
-    (define (default-on-pair pair)
-      (cons (rewrite (car pair))
-            (rewrite (cdr pair))))
-    (define (default-on-vector vec)
-      (vector-map rewrite vec))
-    (define (default-on-error error)
-      (cons 'error
-            (cons (error-object-message error)
-                  (error-object-irritants error))))
-    (define (default-on-condition cond)
-      (map rewrite (condition->list cond)))
-    (define (default-on-record rec)
-      `(record (name ,(rewrite (record-instance-type rec)))
-               (elements
-                ,(vector-map rewrite (record->vector rec)))))
-    (define rewriters
-      (make-parameter
-       `((,pair? . ,default-on-pair)
-         (,vector? . ,default-on-vector)
-         (,error-object? . ,default-on-error)
-         (,condition? . ,default-on-condition)
-         (,record-instance? . ,default-on-record))))
-    (define (rewrite obj)
-      (let loop ((rewriters (rewriters)))
-        (cond
-          ((null? rewriters) obj)
-          (((caar rewriters) obj) ((cdar rewriters) obj))
-          (else (loop (cdr rewriters))))))))
-
diff --git a/lib/cuprate/rewriters/foment.sld b/lib/cuprate/rewriters/foment.sld
deleted file mode 100644
index 248e2ef..0000000
--- a/lib/cuprate/rewriters/foment.sld
+++ /dev/null
@@ -1,32 +0,0 @@
-(define-library (cuprate rewriters foment)
-  (import (scheme base)
-          (only (foment base)
-                error-object-type
-                error-object-who
-                error-object-kind))
-  (export rewriters rewrite)
-  (begin
-    (define (default-on-pair pair)
-      (cons (rewrite (car pair))
-            (rewrite (cdr pair))))
-    (define (default-on-vector vec)
-      (vector-map rewrite vec))
-    (define (default-on-error error)
-      (let ((msg (error-object-message error))
-            (irritants (error-object-irritants error)))
-        `(error (type ,(rewrite (error-object-type error)))
-                (who ,(rewrite (error-object-who error)))
-                (kind ,(rewrite (error-object-kind error)))
-                (msg ,(rewrite (error-object-message error)))
-                (irritants ,@(map rewrite (error-object-irritants error))))))
-    (define rewriters
-      (make-parameter `((,pair? . ,default-on-pair)
-                        (,vector? . ,default-on-vector)
-                        (,error-object? . ,default-on-error))))
-    (define (rewrite obj)
-      (let loop ((rewriters (rewriters)))
-        (cond
-          ((null? rewriters) obj)
-          (((caar rewriters) obj) ((cdar rewriters) obj))
-          (else (loop (cdr rewriters))))))))
-
diff --git a/lib/cuprate/rewriters/r7rs.sld b/lib/cuprate/rewriters/r7rs.sld
deleted file mode 100644
index b231f81..0000000
--- a/lib/cuprate/rewriters/r7rs.sld
+++ /dev/null
@@ -1,24 +0,0 @@
-(define-library (cuprate rewriters r7rs)
-  (import (scheme base))
-  (export rewriters rewrite)
-  (begin
-    (define (default-on-pair pair)
-      (cons (rewrite (car pair))
-            (rewrite (cdr pair))))
-    (define (default-on-vector vec)
-      (vector-map rewrite vec))
-    (define (default-on-error error)
-      (let ((msg (error-object-message error))
-            (irritants (error-object-irritants error)))
-        (cons 'error (cons msg irritants))))
-    (define rewriters
-      (make-parameter `((,pair? . ,default-on-pair)
-                        (,vector? . ,default-on-vector)
-                        (,error-object? . ,default-on-error))))
-    (define (rewrite obj)
-      (let loop ((rewriters (rewriters)))
-        (cond
-          ((null? rewriters) obj)
-          (((caar rewriters) obj) ((cdar rewriters) obj))
-          (else (loop (cdr rewriters))))))))
-
diff --git a/tests/run.scm b/tests/run.scm
index 7b3fac7..d43659f 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -2,7 +2,7 @@
   (chicken-5 (import r7rs))
   (else))
 
-(import (scheme base) (cuprate) (srfi 225) (cuprate rewriters))
+(import (scheme base) (cuprate) (srfi 225))
 (test-set! 'verbose? #t)
 (include "impl.scm")