symbols containing unicode characters now print properly and respect

the print-unicode parameter.
This commit is contained in:
Abdulaziz Ghuloum 2008-08-10 11:50:39 -07:00
parent fdca9ed33f
commit e58c53cca5
2 changed files with 12 additions and 4 deletions

View File

@ -28,7 +28,6 @@
(ikarus system $bytevectors) (ikarus system $bytevectors)
(ikarus system $transcoders) (ikarus system $transcoders)
(only (ikarus.pretty-formats) get-fmt) (only (ikarus.pretty-formats) get-fmt)
;(only (ikarus unicode-data) unicode-printable-char?)
(except (ikarus) (except (ikarus)
write display format printf fprintf print-error print-unicode print-graph write display format printf fprintf print-error print-unicode print-graph
put-datum)) put-datum))
@ -285,6 +284,10 @@
($fxlogand mask ($fxlogand mask
($bytevector-u8-ref map j)))))))) ($bytevector-u8-ref map j))))))))
(define initial-categories
'(Lu Ll Lt Lm Lo Mn Nl No Pd Pc Po Sc Sm Sk So Co))
(define subsequent-categories
'(Nd Mc Me))
(define (write-subsequent* str i j p) (define (write-subsequent* str i j p)
(unless ($fx= i j) (unless ($fx= i j)
@ -295,7 +298,10 @@
(write-char c p)] (write-char c p)]
[($fx< b 128) [($fx< b 128)
(write-inline-hex b p)] (write-inline-hex b p)]
[(unicode-printable-char? c) [(and (print-unicode)
(let ([cat (char-general-category c)])
(or (memq cat initial-categories)
(memq cat subsequent-categories))))
(write-char c p)] (write-char c p)]
[else [else
(write-inline-hex b p)])) (write-inline-hex b p)]))
@ -315,7 +321,9 @@
[(in-map? b0 initials-map) [(in-map? b0 initials-map)
(write-char c0 p)] (write-char c0 p)]
[($fx< b0 128) (write-inline-hex b0 p)] [($fx< b0 128) (write-inline-hex b0 p)]
[(unicode-printable-char? c0) (write-char c0 p)] [(and (print-unicode)
(memq (char-general-category c0) initial-categories))
(write-char c0 p)]
[else (write-inline-hex b0 p)]) [else (write-inline-hex b0 p)])
(write-subsequent* str 1 n p))])))) (write-subsequent* str 1 n p))]))))

View File

@ -1 +1 @@
1582 1583