make macro generators, test on chibi. Currently broken in CHICKEN-5 due to a bug in compiled syntax-rules macros

3 files changed, 91 insertions, 0 deletions

diff --git a/lib/cuprate/rewriters/chicken.sld b/lib/cuprate/rewriters/chicken.sld
new file mode 100644
index 0000000..f92f998
--- /dev/null
+++ b/lib/cuprate/rewriters/chicken.sld
@@ -0,0 +1,35 @@
+(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
new file mode 100644
index 0000000..6f88ea5
--- /dev/null
+++ b/lib/cuprate/rewriters/foment.sld
@@ -0,0 +1,32 @@
+(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 (test-rewrite (car pair))
+            (test-rewrite (cdr pair))))
+    (define (default-on-vector vec)
+      (vector-map test-rewrite vec))
+    (define (default-on-error error)
+      (let ((msg (error-object-message error))
+            (irritants (error-object-irritants error)))
+        `(error (type ,(test-rewrite (error-object-type error)))
+                (who ,(test-rewrite (error-object-who error)))
+                (kind ,(test-rewrite (error-object-kind error)))
+                (msg ,(test-rewrite (error-object-message error)))
+                (irritants ,@(map test-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
new file mode 100644
index 0000000..b231f81
--- /dev/null
+++ b/lib/cuprate/rewriters/r7rs.sld
@@ -0,0 +1,24 @@
+(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))))))))
+