move rewriters to implementation file, make rewriter cycle-detecting

9 files changed, 96 insertions, 21 deletions

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