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

* pretty-print is now added to ikarus. 

* new-cafe now uses pretty-print instead of write for printing to
  the interaction repl.
This commit is contained in:
Abdulaziz Ghuloum 2007-01-13 21:33:04 -05:00
parent bf23a8a1b7
commit 92e278281c
4 changed files with 32 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

3
src/libcafe.ss
View File

@ -79,8 +79,7 @@ description:
(unless (andmap (lambda (v) (eq? v (void))) v*) (unless (andmap (lambda (v) (eq? v (void))) v*)
(for-each (for-each
(lambda (v) (lambda (v)
(write v (console-output-port)) (pretty-print v (console-output-port)))
(newline (console-output-port)))
v*))))])))))) v*))))]))))))
(wait eval escape-k))) (wait eval escape-k)))

86
lab/pretty-print.ss → src/libpp.ss
View File

@ -1,6 +1,5 @@
(module (pretty-print) (let ()
(import-only scheme) (define (pretty-width) 70)
(define (pretty-width) 60)
(define-record cbox (length boxes)) (define-record cbox (length boxes))
(define-record lbox (length boxes)) (define-record lbox (length boxes))
(define-record sbox (length string)) (define-record sbox (length string))
@ -26,18 +25,6 @@
[else [else
(f (cdr a*) (fx+ len (box-length (car a*))))]))]) (f (cdr a*) (fx+ len (box-length (car a*))))]))])
(make-cbox n a*))) (make-cbox n a*)))
(define (boxify-symbol x)
(define (boxify-symbol-string x)
(define (valid-symbol-string? x) #t) ;;; FIXME
(define (barify x) (error 'barify "NOT YET")) ;;; FIXME
(if (valid-symbol-string? x)
x
(conc "|" (barify x) "|")))
(let ([name (symbol->string x)])
(cond
[(gensym? x)
(conc "#:" (boxify-symbol-string name))]
[else (boxify-symbol-string name)])))
(define (boxify-list ls) (define (boxify-list ls)
(define (boxify-list-generic ls) (define (boxify-list-generic ls)
(let ([ls (map boxify ls)]) (let ([ls (map boxify ls)])
@ -108,21 +95,6 @@
(fx+ (fxadd1 n) (box-length (car ls))))]))]) (fx+ (fxadd1 n) (box-length (car ls))))]))])
(make-pbox (fx+ n (box-length last)) ls last)))) (make-pbox (fx+ n (box-length last)) ls last))))
(define char-table ; first nonprintable chars
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
(define (boxify-char x)
(let ([n (char->integer x)])
(cond
[(fx< n (vector-length char-table))
(conc "#\\" (vector-ref char-table n))]
[(fx< n 128)
(string #\# #\\ x)]
[else
(string #\# #\c
(hexify (fxquotient n 16))
(hexify (fxremainder n 16)))])))
(define (boxify-vector x) (define (boxify-vector x)
(let ([ls (map boxify (vector->list x))]) (let ([ls (map boxify (vector->list x))])
(let ([n (let ([n
@ -133,18 +105,12 @@
(f (cdr ls) (fx+ n (box-length (car ls))))]))]) (f (cdr ls) (fx+ n (box-length (car ls))))]))])
(make-vbox (fx+ (fx+ n 2) (vector-length x)) ls)))) (make-vbox (fx+ (fx+ n 2) (vector-length x)) ls))))
(cond (cond
[(number? x) (number->string x)]
[(symbol? x) (boxify-symbol x)]
[(string? x) (boxify-string x)] [(string? x) (boxify-string x)]
[(null? x) "()"] [(null? x) "()"]
[(boolean? x) (if x "#t" "#f")]
[(vector? x) (boxify-vector x)] [(vector? x) (boxify-vector x)]
[(list? x) (boxify-list x)] [(list? x) (boxify-list x)]
[(pair? x) (boxify-pair x)] [(pair? x) (boxify-pair x)]
[(char? x) (boxify-char x)] [else (format "~s" x)]))
[(procedure? x) "#<procedure>"]
[(eq? x (void)) "#<void>"]
[else "#<unknown>"]))
(define string-esc-table (define string-esc-table
'((7 . "a") '((7 . "a")
@ -369,23 +335,26 @@
(let ([x (boxify x)]) (let ([x (boxify x)])
(output x p))) (output x p)))
;;; ;;;
(define pretty-print (define (set-fmt! name fmt)
(putprop name '*pretty-format* fmt))
(primitive-set! 'pretty-print
(case-lambda (case-lambda
[(x) (pretty x (current-output-port))] [(x) (pretty x (current-output-port))]
[(x p) [(x p)
(if (output-port? p) (if (output-port? p)
(pretty x p) (pretty x p)
(error 'pretty-print "~s is not an output port" p))])) (error 'pretty-print "~s is not an output port" p))]))
(define (set-fmt! name fmt)
(putprop name '*pretty-format* fmt))
(set-fmt! 'quote '(reader-macro . "'")) (set-fmt! 'quote '(reader-macro . "'"))
(set-fmt! 'unquote '(reader-macro . ",")) (set-fmt! 'unquote '(reader-macro . ","))
(set-fmt! 'unquote-splicing '(reader-macro . ",@")) (set-fmt! 'unquote-splicing '(reader-macro . ",@"))
(set-fmt! 'quasiquote '(reader-macro . "`")) (set-fmt! 'quasiquote '(reader-macro . "`"))
(set-fmt! 'syntax '(reader-macro . "#'")) (set-fmt! 'syntax '(reader-macro . "#'"))
(set-fmt! '|#primitive| '(reader-macro . "#%")) (set-fmt! '|#primitive| '(reader-macro . "#%"))
(set-fmt! 'define '(_ name tab e tab e ...))
) )
#!eof
(define (test x) (define (test x)
(pretty-print x) (pretty-print x)
(printf "====================================\n")) (printf "====================================\n"))
@ -436,31 +405,34 @@
(printf "testing file ~s ...\n" x) (printf "testing file ~s ...\n" x)
(with-input-from-file x (with-input-from-file x
(lambda () (lambda ()
(let f () (let f ([i 0])
(let ([x (read)]) (let ([x (read)] [fname (format "tmp.~a.pp" i)])
(unless (eof-object? x) (unless (eof-object? x)
(let ([y (let ([y
(begin (begin
(call-with-output-file "tmp.pp" (call-with-output-file fname
(lambda (p) (lambda (p)
(pretty-print x p)) (pretty-print x p))
'replace) 'replace)
(with-input-from-file "tmp.pp" read))]) (with-input-from-file fname read))])
(if (equal? x y) (if (equal? x y)
(f) (f (fxadd1 i))
(error 'test-file "mismatch ~s ~s" x y))))))))) (error 'test-file "mismatch ~s ~s" x y)))))))))
(for-each test-file (for-each test-file
'("../src/fact.ss" "../src/libhash.ss" "../src/foo.ss" '(;"../src/fact.ss" "../src/libhash.ss" "../src/foo.ss"
"../src/libintelasm.ss" "../src/libassembler.ss" ;"../src/libintelasm.ss" "../src/libassembler.ss"
"../src/libnumerics.ss" "../src/libcafe.ss" "../src/libposix.ss" ;"../src/libnumerics.ss" "../src/libcafe.ss" "../src/libposix.ss"
"../src/libchezio.ss" "../src/librecord.ss" ;"../src/libchezio.ss" "../src/librecord.ss"
"../src/libcollect.ss" "../src/libtimers.ss" ;"../src/libcollect.ss" "../src/libtimers.ss"
"../src/libcompile.ss" "../src/libtokenizer.ss" "../src/libcompile.ss"
"../src/libcontrol.ss" "../src/libtoplevel.ss" ;"../src/libtokenizer.ss"
"../src/libcore.ss" "../src/libtrace.ss" "../src/libcxr.ss" ;"../src/libcontrol.ss" "../src/libtoplevel.ss"
"../src/libwriter.ss" "../src/libengines.ss" "../src/makefile.ss" ;"../src/libcore.ss" "../src/libtrace.ss" "../src/libcxr.ss"
"../src/libfasl.ss" "../src/psyntax-7.1.ss" ;"../src/libwriter.ss" "../src/libengines.ss"
"../src/libguardians.ss" "../src/self-exporting-module.ss" ;"../src/libfasl.ss"
"../src/libhandlers.ss" "../src/set-operations.ss")) ;"../src/libguardians.ss" "../src/self-exporting-module.ss"
;"../src/libhandlers.ss" "../src/set-operations.ss"
;"../src/psyntax-7.1.ss"
))

2
src/makefile.ss
View File

@ -87,6 +87,7 @@
interrupt-handler interrupt-handler
time-it time-it
posix-fork fork waitpid env environ posix-fork fork waitpid env environ
pretty-print
)) ))
(define system-primitives (define system-primitives
@ -230,6 +231,7 @@
["libfasl.ss" "libfasl.fasl" p0] ["libfasl.ss" "libfasl.fasl" p0]
["libcompile.ss" "libcompile.fasl" p1] ["libcompile.ss" "libcompile.fasl" p1]
["psyntax-7.1.ss" "psyntax.fasl" p0] ["psyntax-7.1.ss" "psyntax.fasl" p0]
["libpp.ss" "libpp.fasl" p0]
["libcafe.ss" "libcafe.fasl" p0] ["libcafe.ss" "libcafe.fasl" p0]
["libtrace.ss" "libtrace.fasl" p0] ["libtrace.ss" "libtrace.fasl" p0]
["libposix.ss" "libposix.fasl" p0] ["libposix.ss" "libposix.fasl" p0]