Initial commit of RLA-style output library, src/lib/writer.rls.

src/lib/writer.rls

@@ -0,0 +1,178 @@
+;(load "lib/primitives.rls")
+;(load "lib/primitive/foldl.rls")
+;(load "lib/primitive/foldr.rls")
+;(load "lib/primitive/reverse.rls")
+;(load "lib/primitive/map.rls")
+;(load "lib/primitive/append.rls")
+;(load "lib/util.rls")
+;(load "lib/hash-table.rls")
+;(load "lib/symbols.rls")
+;(load "lib/keywords.rls")
+;(load "lib/parameters.rls")
+;(load "lib/abort.rls")
+;(load "lib/errors.rls")
+;(load "lib/port.rls")
+;(load "lib/display.rls")
+
+(define (default-unwritable-value-handler value port)
+  (write-string "#<unwritable>" port))
+
+(define current-unwritable-value-handler (make-parameter default-unwritable-value-handler))
+
+(define next-reference-number   (make-parameter #f))
+(define current-reference-table (make-parameter #f))
+
+(define (write-rla value [port (current-output-port)])
+  (call-with-parameters
+    (lambda ()
+      (identify-backrefs value)
+      (write-rla-value value))
+   (list current-output-port port)
+   (list current-reference-table (make-hash-table hash-value eq?))
+   (list next-reference-number 0)))
+
+(define (identify-backrefs value)
+  (cond
+   [(or (boolean? value) (fixnum? value) (float? value) (builtin->string value)) void]
+   [else
+     (let ([new? #t])
+       (hash-table-insert (current-reference-table) value #f
+                          (lambda (oldv) (set! new? #f) #t))
+       (when new?
+          (cond
+           [(box? value)
+              (identify-backrefs (unbox value))]
+           [(weak-box? value)
+              (identify-backrefs (weak-unbox value))]
+           [(pair? value)
+              (identify-backrefs (car value))
+              (identify-backrefs (cdr value))]
+           [(struct? value)
+              (identify-backrefs (struct-type value))
+              (let ([nslots (struct-nslots value)])
+                (let iter ([n 0])
+                  (when (fix< n nslots)
+                    (identify-backrefs (struct-ref value n))
+                    (iter (fix+ n 1)))))]
+           [(vector? value)
+              (let ([size (vector-size value)])
+                (let iter ([n 0])
+                  (when (fix< n size)
+                    (identify-backrefs (vector-ref value n))
+                    (iter (fix+ n 1)))))])))]))
+                    
+(define (take-next-number)
+  (let ([n (next-reference-number)])
+    (next-reference-number (fix+ n 1))
+    n))
+
+(define (write-rla-value value)
+  (cond
+   [(eq? value #f)  (write-string "#f")]
+   [(eq? value #t)  (write-string "#t")]
+   [(eq? value '()) (write-string "()")]
+   [(fixnum? value) (write-string (number->string value))]
+   [(float? value)  (write-string "#<float>")]
+   [else (let ([builtin-name (builtin->string value)])
+           (if builtin-name
+               (write-builtin builtin-name)
+               (write-rla-object/backref value)))]))
+
+(define (write-builtin name)
+  (write-string "#=")
+  (write-rla-byte-string name))
+
+(define (write-rla-object/backref obj)
+  (let* ([ht (current-reference-table)]
+         [backref (hash-table-lookup ht obj)])
+    (cond
+     [(fixnum? backref)
+       (write-backref backref)]
+     [backref
+       (let ([n (take-next-number)])
+         (hash-table-insert ht obj n)
+         (write-backref-definition n)
+         (write-rla-object obj))]
+     [else
+       (write-rla-object obj)])))
+
+(define (write-backref number)
+  (write-char #\#)
+  (write-char #\=)
+  (display number))
+
+(define (write-backref-definition number)
+  (write-char #\#)
+  (display number)
+  (write-char #\=))
+
+(define (write-rla-object obj)
+  (when (immutable? obj) (write-string "#@"))
+  (cond
+   [(box?         obj) (write-string "#&")
+                       (write-rla-value (unbox obj))]
+   [(weak-box?    obj) (write-string "#W&")
+                       (write-rla-value (weak-unbox obj))]
+   [(pair?        obj) (write-rla-list        obj)]
+   [(struct?      obj) (write-rla-struct      obj)]
+   [(vector?      obj) (write-rla-vector      obj)]
+   [(byte-string? obj) (write-rla-byte-string obj)]
+   [else ((current-unwritable-value-handler)  obj (current-output-port))]))
+
+(define (write-rla-byte-string str)
+  (define (number->hexadecimal digit) (byte-string-ref "0123456789abcdef" digit))
+  (write-char #\")
+  (let iter ([i 0])
+    (when (fix< i (byte-string-size str))
+      (let ([ch (byte-string-ref str i)])
+        (if (or (and (fix>= ch 32) (fix<= ch 33))
+                (and (fix>= ch 35) (fix<= ch 91))
+                (and (fix>= ch 93) (fix<= ch 126)))
+            (write-char ch)
+            (begin
+              (write-string "\\x")
+              (write-char (number->hexadecimal (fix/ ch 16)))
+              (write-char (number->hexadecimal (fix% ch 16))))))
+      (iter (fix+ i 1))))
+  (write-char #\"))
+
+(define (write-rla-list lst)
+  (write-char #\()
+  (write-rla-value (car lst))
+  (let iter ([rst (cdr lst)])
+    (cond
+     [(null? rst)
+       (write-char #\))]
+     [(or (not (pair? rst))
+          (hash-table-lookup (current-reference-table) rst))
+       (write-string " . ")
+       (write-rla-value rst)
+       (write-char #\))]
+     [else
+       (write-char #\Space)
+       (write-rla-value (car rst))
+       (iter (cdr rst))])))
+
+(define (write-rla-struct obj)
+  (write-string "#S(")
+  (write-rla-value (struct-type obj))
+  (let ([nslots (struct-nslots obj)])
+    (let iter ([n 0])
+      (when (fix< n nslots)
+        (write-char #\Space)
+        (write-rla-value (struct-ref obj n))
+        (iter (fix+ n 1)))))
+  (write-char #\)))
+
+(define (write-rla-vector obj)
+  (write-string "#(")
+  (let ([size (vector-size obj)])
+    (let iter ([n 0])
+      (when (fix< n size)
+        (when (fix> n 0)
+          (write-char #\Space))
+        (write-rla-value (vector-ref obj n))
+        (iter (fix+ n 1)))))
+  (write-char #\)))
+
+; vim:set syntax=scheme sw=2 expandtab:

src/test-writer.rls

@@ -0,0 +1,33 @@
+(load "lib/primitives.rls")
+(load "lib/primitive/foldl.rls")
+(load "lib/primitive/foldr.rls")
+(load "lib/primitive/reverse.rls")
+(load "lib/primitive/map.rls")
+(load "lib/primitive/append.rls")
+(load "lib/util.rls")
+(load "lib/hash-table.rls")
+(load "lib/symbols.rls")
+(load "lib/keywords.rls")
+(load "lib/parameters.rls")
+(load "lib/abort.rls")
+(load "lib/errors.rls")
+(load "lib/port.rls")
+(load "lib/display.rls")
+(load "lib/writer.rls")
+
+(write-rla 4)
+(write-char #\Newline)
+(write-rla '(1 2 3))
+(write-char #\Newline)
+(write-rla (let ([x (cons 1 '())]) (set-cdr! x x) x))
+(write-char #\Newline)
+(write-rla "abc")
+(write-char #\Newline)
+(write-rla "\n")
+(write-char #\Newline)
+(write-rla '#(1 2 3))
+(write-char #\Newline)
+(write-rla 'a)
+(write-char #\Newline)
+(write-rla (lambda () 'a))
+(write-char #\Newline)