conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

moved pretty-printing formats to their own library.

This commit is contained in:
Abdulaziz Ghuloum 2008-05-12 00:35:19 -07:00
parent f05f171f28
commit 4acf71d6d2
5 changed files with 67 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
scheme/ikarus.pretty-formats.ss Normal file
View File

@ -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 ...))
)

57
scheme/ikarus.pretty-print.ss
View File

@ -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

3
scheme/ikarus.writer.ss
View File

@ -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)))

2
scheme/last-revision
View File

@ -1 +1 @@
1472
1473

1
scheme/makefile.ss
View File

@ -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"