* Writer and pretty-printer now print things more like what r6rs

requires as far as symbols and strings are concerned.

src/ikarus.pretty-print.ss

@@ -217,7 +217,7 @@
                     (f (cdr ls) (fx+ n (box-length (car ls))))]))])
           (make-vbox (fx+ (fx+ n 2) (vector-length x)) ls))))
     (cond
-      [(string? x)    (boxify-string x)]
+     ; [(string? x)    (boxify-string x)]
       [(null? x)      "()"]
       [(vector? x)    (boxify-vector x)]
       [(list? x)      (boxify-list x '())]

src/ikarus.writer.ss

@@ -169,14 +169,6 @@
           (and (subsequent? ($string-ref str i))
                (subsequent*? str ($fxadd1 i) n)))))
   
-  (define valid-symbol-string?
-    (lambda (str)
-      (define normal-symbol-string?
-        (lambda (str)
-          (let ([n ($string-length str)])
-            (and ($fx>= n 1)
-                 (initial? ($string-ref str 0))
-                 (subsequent*? str 1 n)))))
   (define peculiar-symbol-string?
     (lambda (str)
       (let ([n (string-length str)])
@@ -187,33 +179,143 @@
            (or (and (char=? (string-ref str 0) #\-)
                     (char=? (string-ref str 1) #\>)
                     (subsequent*? str 2 n))
-                   (string=? str "..."))]))))
+               (string=? str "..."))]
+          [else #f]))))
+
+  (define valid-symbol-string?
+    (lambda (str)
+      (define normal-symbol-string?
+        (lambda (str)
+          (let ([n ($string-length str)])
+            (and ($fx>= n 1)
+                 (initial? ($string-ref str 0))
+                 (subsequent*? str 1 n)))))
       (or (normal-symbol-string? str)
           (peculiar-symbol-string? str))))
   
-  (define write-symbol-esc-loop
+  (define write-symbol-bar-esc-loop
     (lambda (x i n p)
       (unless ($fx= i n)
-        (let ([c ($string-ref x i)])
+        (let* ([c ($string-ref x i)]
-          (when (memq c '(#\\ #\|))
+               [b ($char->fixnum c)])
-            (write-char #\\ p))
+          (cond
-          (write-char c p))
+            [($fx< b 32)
-        (write-symbol-esc-loop x ($fxadd1 i) n p))))
+             (cond
+               [($fx< b 7) 
+                (write-inline-hex b p)]
+               [($fx< b 14)
+                (write-char #\\ p)
+                (write-char (string-ref "abtnvfr" ($fx- b 7)) p)]
+               [else 
+                (write-inline-hex b p)])]
+            [(memq c '(#\\ #\|))
+             (write-char #\\ p)
+             (write-char c p)]
+            [($fx< b 127) 
+             (write-char c p)]
+            [else 
+             (write-inline-hex b p)]))
+        (write-symbol-bar-esc-loop x ($fxadd1 i) n p))))
   
-  (define write-symbol-esc
+  (define write-symbol-bar-esc
     (lambda (x p)
       (write-char #\| p)
-      (write-symbol-esc-loop x 0 ($string-length x) p)
+      (write-symbol-bar-esc-loop x 0 ($string-length x) p)
       (write-char #\| p)))
   
+  (define-syntax ascii-map
+    (lambda (x)
+      ;;; r6rs prohibits bytevectors from being "datum"s
+      ;;; oh well.
+      (syntax-case x ()
+        [(stx str) (string? (syntax->datum #'str))
+         (let ([s (syntax->datum #'str)]
+               [bv (make-bytevector 16 0)])
+           (for-each
+             (lambda (c)
+               (let ([b (char->integer c)])
+                 (let ([i (fxlogand b 7)]
+                       [j (fxsra b 3)])
+                   (bytevector-u8-set! bv j
+                     (fxlogor (bytevector-u8-ref bv j)
+                       (fxsll 1 i))))))
+             (string->list s))
+           (with-syntax ([bv (datum->syntax #'stx bv)])
+             #'(quote bv)))])))
+
+  (define subsequents-map 
+   (ascii-map
+     "!$%&*/:<=>?^_~+-.@abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
+  (define initials-map
+   (ascii-map
+     "!$%&*/:<=>?^_~abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
+
+
+  (define (in-map? byte map)
+    (let ([i ($fxlogand byte 7)]
+          [j ($fxsra byte 3)])
+      (and 
+        (fx< j ($bytevector-length map))
+        (let ([mask ($fxsll 1 i)])
+           (not ($fxzero? 
+                  ($fxlogand mask
+                    ($bytevector-u8-ref map j))))))))
+
+
+  (define (write-subsequent* str i j p)
+    (unless ($fx= i j) 
+      (let* ([c ($string-ref str i)]
+             [b ($char->fixnum c)])
+        (cond
+          [(in-map? b subsequents-map) 
+           (write-char c p)]
+          [else 
+           (write-inline-hex b p)]))))
+
+  (define write-symbol-hex-esc
+    (lambda (str p)
+      (let ([n ($string-length str)])
+        (cond
+          [($fx= n 0) 
+           (write-char #\| p) 
+           (write-char #\| p)]
+          [else
+           (let* ([c0 ($string-ref str 0)]
+                  [b0 ($char->fixnum c0)])
+             (cond
+               [(in-map? b0 initials-map) (write-char c0 p)]
+               [else (write-inline-hex b0 p)])
+             (write-subsequent* str 1 n p))]))))
+
+
+  (define (write-peculiar str p)
+    (let ([n ($string-length str)])
+      (cond
+        [($fx= n 1) 
+         (write-char ($string-ref str 0) p)]
+        [(and ($fx>= n 2) 
+              ($char= ($string-ref str 0) #\-)
+              ($char= ($string-ref str 1) #\>))
+         (write-char #\- p)
+         (write-char #\> p)
+         (write-subsequent* str 2 n p)]
+        [(string=? str "...")
+         (write-char #\. p)
+         (write-char #\. p)
+         (write-char #\. p)]
+        [else (error 'write-peculiear "BUG")])))
+
   (define write-symbol
     (lambda (x p m)
-      (let ([str (symbol->string x)])
+      (write-symbol-string (symbol->string x) p m)))
+
+  (define write-symbol-string
+    (lambda (str p m)
       (if m
-            (if (valid-symbol-string? str)
+          (if (peculiar-symbol-string? str)
-                (write-char* str p)
+              (write-peculiar str p)
-                (write-symbol-esc str p))
+              (write-symbol-hex-esc str p))
-            (write-char* str p)))))
+          (write-char* str p))))
   
   (define write-gensym
     (lambda (x p m h i)
@@ -225,45 +327,53 @@
               (let ([str (symbol->string x)])
                 (write-char #\# p)
                 (write-char #\: p)
-                (if (valid-symbol-string? str)
+                (write-symbol-string str p m))]
-                    (write-char* str p)
-                    (write-symbol-esc str p)))]
              [else
-              (let ([str (symbol->string x)])
+              (let ([str (symbol->string x)]
+                    [ustr (gensym->unique-string x)])
                 (write-char #\# p)
                 (write-char #\{ p)
-                (if (valid-symbol-string? str)
+                (write-symbol-string str p m)
-                    (write-char* str p)
-                    (write-symbol-esc str p))
                 (write-char #\space p)
-                (write-symbol-esc (gensym->unique-string x) p)
+                (write-symbol-bar-esc ustr p)
                 (write-char #\} p))])
            i)]
         [else 
          (write-symbol x p m)
          i])))
   
+  (define write-inline-hex
+    (lambda (b p)
+      (write-char #\\ p)
+      (write-char #\x p)
+      (if ($fxzero? b) 
+          (write-char #\0 p)
+          (write-positive-hex-fx b p))
+      (write-char #\; p)))
+
   (define write-string-escape
     (lambda (x p)
       (define loop 
         (lambda (x i n p)
          (unless (fx= i n)
-           (let ([c (string-ref x i)])
+           (let* ([c (string-ref x i)]
+                  [b ($char->fixnum c)])
              (cond
+               [($fx< b 32) 
+                (cond
+                  [($fx< b 7) 
+                   (write-inline-hex b p)]
+                  [($fx< b 14)
+                   (write-char #\\ p)
+                   (write-char (string-ref "abtnvfr" ($fx- b 7)) p)]
+                  [else 
+                   (write-inline-hex b p)])]
                [(or ($char= #\" c) ($char= #\\ c))
                 (write-char #\\ p)
                 (write-char c p)]
-               [($char= #\newline c)
+               [($fx< b 127)
-                (write-char #\\ p)
+                (write-char c p)]
-                (write-char #\n p)] 
+               [else (write-inline-hex b p)]))
-               [($char= #\return c)
-                (write-char #\\ p)
-                (write-char #\r p)] 
-               [($char= #\tab c)
-                (write-char #\\ p)
-                (write-char #\t p)]
-               [else
-                (write-char c p)]))
            (loop x (fxadd1 i) n p)))) 
       (write-char #\" p)
       (loop x 0 (string-length x) p)