From 4acf71d6d2c0f17e3e15bebd6983bd9cc0b92ab5 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Mon, 12 May 2008 00:35:19 -0700
Subject: [PATCH] moved pretty-printing formats to their own library.

---
 scheme/ikarus.pretty-formats.ss | 59 +++++++++++++++++++++++++++++++++
 scheme/ikarus.pretty-print.ss   | 57 +++----------------------------
 scheme/ikarus.writer.ss         |  3 +-
 scheme/last-revision            |  2 +-
 scheme/makefile.ss              |  1 +
 5 files changed, 67 insertions(+), 55 deletions(-)
 create mode 100644 scheme/ikarus.pretty-formats.ss

diff --git a/scheme/ikarus.pretty-formats.ss b/scheme/ikarus.pretty-formats.ss
new file mode 100644
index 0000000..374e328
--- /dev/null
+++ b/scheme/ikarus.pretty-formats.ss
@@ -0,0 +1,59 @@
+(library (ikarus.pretty-formats)
+  (export get-fmt pretty-format)
+  (import (except (ikarus) pretty-format))
+
+  (define *pretty-format* '*pretty-format*)
+  (define (get-fmt name)
+    (getprop name *pretty-format*))
+  (define (set-fmt! name fmt)
+    (putprop name *pretty-format* fmt))
+
+
+  (define pretty-format
+    (lambda (x)
+      (unless (symbol? x)
+        (die 'pretty-format "not a symbol" x))
+      (case-lambda
+        [() (getprop x *pretty-format*)]
+        [(v) (putprop x *pretty-format* v)])))
+
+  ;;; standard formats
+  (set-fmt! 'quote '(read-macro . "'"))
+  (set-fmt! 'unquote '(read-macro . ","))
+  (set-fmt! 'unquote-splicing '(read-macro . ",@"))
+  (set-fmt! 'quasiquote '(read-macro . "`"))
+  (set-fmt! 'syntax '(read-macro . "#'"))
+  (set-fmt! 'quasisyntax '(read-macro . "#`"))
+  (set-fmt! 'unsyntax '(read-macro . "#,"))
+  (set-fmt! 'unsyntax-splicing '(read-macro . "#,@"))
+  ;(set-fmt! '|#primitive| '(read-macro . "#%"))
+  (set-fmt! 'let '(alt 
+                    (_ (0 [e 0 e] ...) tab e ...)
+                    (_ x (0 [e 0 e] ...) tab e ...)))
+  (set-fmt! 'letrec '(_ (0 [e 0 e] ...) tab e ...))
+  (set-fmt! 'letrec* '(_ (0 [e 0 e] ...) tab e ...))
+  (set-fmt! 'let-syntax '(_ (0 [e 0 e] ...) tab e ...))
+  (set-fmt! 'letrec-syntax '(_ (0 [e 0 e] ...) tab e ...))
+  (set-fmt! 'let* '(_ (0 [e 0 e] ...) tab e ...))
+  (set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...))
+  (set-fmt! 'cond '(_ tab [0 e ...] ...))
+  (set-fmt! 'define '(_ name tab e ...))
+  (set-fmt! 'case-lambda 
+     '(_ tab [0 e ...] ...))
+  (set-fmt! 'struct-case 
+     '(_ e tab [e 0 e ...] ...))
+  (set-fmt! 'if '(_ test 3 e ...))
+  (set-fmt! 'and '(and test 4 e ...))
+  (set-fmt! 'or '(or test 3 e ...))
+  (set-fmt! 'begin '(_ tab e ...))
+  (set-fmt! 'lambda '(_ fmls tab e tab e* ...))
+  (set-fmt! 'case '(_ e tab [e 0 e] ...))
+  (set-fmt! 'syntax-rules '(_ kwd* tab [e 0 e] ...))
+  (set-fmt! 'syntax-case '(_ expr kwd*  
+                             tab (e 0 e 0 e ...) ...))
+  (set-fmt! 'module '(alt (_ (fill ...) tab e ...)
+                          (_ name (fill ...) tab e ...)))
+  (set-fmt! 'library '(_ name tab e ...))
+  (set-fmt! 'import '(_ tab e ...))
+
+)
diff --git a/scheme/ikarus.pretty-print.ss b/scheme/ikarus.pretty-print.ss
index e93f27f..4f3b731 100644
--- a/scheme/ikarus.pretty-print.ss
+++ b/scheme/ikarus.pretty-print.ss
@@ -15,10 +15,11 @@
 
 
 (library (ikarus pretty-print)
-  (export pretty-print pretty-width pretty-format)
+  (export pretty-print pretty-width)
   (import 
     (rnrs hashtables)
-    (except (ikarus) pretty-print pretty-width pretty-format))
+    (only (ikarus.pretty-formats) get-fmt)
+    (except (ikarus) pretty-print pretty-width))
   (define (map1ltr f ls)
     ;;; ltr so that gensym counts get assigned properly
     (cond
@@ -98,7 +99,7 @@
                 alt-fmt*))
       (define (applicable-formats a alt-fmt*)
         (cond
-          [(and (symbol? a) (getprop a *pretty-format*)) =>
+          [(and (symbol? a) (get-fmt a)) =>
            (lambda (fmt) 
              (cond
                [(and (pair? fmt) (eq? (car fmt) 'alt))
@@ -599,9 +600,6 @@
   (define (pretty x p)
     (output (boxify (unshare x)) p))
   ;;;
-  (define *pretty-format* '*pretty-format*)
-  (define (set-fmt! name fmt)
-    (putprop name *pretty-format* fmt))
   (define pretty-print 
     (case-lambda
       [(x) (pretty x (current-output-port))]
@@ -610,53 +608,6 @@
            (pretty x p)
            (die 'pretty-print "not an output port" p))]))
 
-  (define pretty-format
-    (lambda (x)
-      (unless (symbol? x)
-        (die 'pretty-format "not a symbol" x))
-      (case-lambda
-        [() (getprop x '*pretty-format*)]
-        [(v) (putprop x '*pretty-format* v)])))
-
-  ;;; standard formats
-  (set-fmt! 'quote '(read-macro . "'"))
-  (set-fmt! 'unquote '(read-macro . ","))
-  (set-fmt! 'unquote-splicing '(read-macro . ",@"))
-  (set-fmt! 'quasiquote '(read-macro . "`"))
-  (set-fmt! 'syntax '(read-macro . "#'"))
-  (set-fmt! 'quasisyntax '(read-macro . "#`"))
-  (set-fmt! 'unsyntax '(read-macro . "#,"))
-  (set-fmt! 'unsyntax-splicing '(read-macro . "#,@"))
-  ;(set-fmt! '|#primitive| '(read-macro . "#%"))
-  (set-fmt! 'let '(alt 
-                    (_ (0 [e 0 e] ...) tab e ...)
-                    (_ x (0 [e 0 e] ...) tab e ...)))
-  (set-fmt! 'letrec '(_ (0 [e 0 e] ...) tab e ...))
-  (set-fmt! 'letrec* '(_ (0 [e 0 e] ...) tab e ...))
-  (set-fmt! 'let-syntax '(_ (0 [e 0 e] ...) tab e ...))
-  (set-fmt! 'letrec-syntax '(_ (0 [e 0 e] ...) tab e ...))
-  (set-fmt! 'let* '(_ (0 [e 0 e] ...) tab e ...))
-  (set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...))
-  (set-fmt! 'cond '(_ tab [0 e ...] ...))
-  (set-fmt! 'define '(_ name tab e ...))
-  (set-fmt! 'case-lambda 
-     '(_ tab [0 e ...] ...))
-  (set-fmt! 'struct-case 
-     '(_ e tab [e 0 e ...] ...))
-  (set-fmt! 'if '(_ test 3 e ...))
-  (set-fmt! 'and '(and test 4 e ...))
-  (set-fmt! 'or '(or test 3 e ...))
-  (set-fmt! 'begin '(_ tab e ...))
-  (set-fmt! 'lambda '(_ fmls tab e tab e* ...))
-  (set-fmt! 'case '(_ e tab [e 0 e] ...))
-  (set-fmt! 'syntax-rules '(_ kwd* tab [e 0 e] ...))
-  (set-fmt! 'syntax-case '(_ expr kwd*  
-                             tab (e 0 e 0 e ...) ...))
-  (set-fmt! 'module '(alt (_ (fill ...) tab e ...)
-                          (_ name (fill ...) tab e ...)))
-  (set-fmt! 'library '(_ name tab e ...))
-  (set-fmt! 'import '(_ tab e ...))
-
   )
 
 #!eof
diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss
index 184bb88..21535d1 100644
--- a/scheme/ikarus.writer.ss
+++ b/scheme/ikarus.writer.ss
@@ -27,6 +27,7 @@
     (ikarus system $symbols)
     (ikarus system $bytevectors)
     (ikarus system $transcoders)
+    (only (ikarus.pretty-formats) get-fmt)
     (only (ikarus unicode-data) unicode-printable-char?) 
     (except (ikarus) 
       write display format printf fprintf print-error print-unicode print-graph
@@ -458,7 +459,7 @@
               (and (pair? d)
                 (null? ($cdr d))
                 (not (hashtable-ref h x #f))))
-            (let ([p ((pretty-format a))])
+            (let ([p (get-fmt a)])
               (and (pair? p)
                 (eq? (car p) 'read-macro)
                 (string? (cdr p)))
diff --git a/scheme/last-revision b/scheme/last-revision
index bfc0bcc..2478883 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1472
+1473
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 1a23bd3..c5fd101 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -72,6 +72,7 @@
     "ikarus.bytevectors.ss"
     "ikarus.io.ss"
     "ikarus.hash-tables.ss"
+    "ikarus.pretty-formats.ss"
     "ikarus.writer.ss"
     "ikarus.reader.ss"
     "ikarus.code-objects.ss"