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

* Added transcoder-codec, transcoder-eol-style, and 

transcoder-error-handling-mode
This commit is contained in:
Abdulaziz Ghuloum 2007-10-12 00:00:36 -04:00
parent fdc0132573
commit 63975eba38
4 changed files with 43 additions and 8 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.

39
src/ikarus.codecs.ss
View File

@ -2,11 +2,13 @@
(library (ikarus codecs)
(export latin-1-codec utf-8-codec utf-16-codec native-eol-style
make-transcoder native-transcoder buffer-mode?
file-options-spec)
file-options-spec transcoder-codec transcoder-eol-style
transcoder-error-handling-mode)
(import
(except (ikarus) latin-1-codec utf-8-codec utf-16-codec
native-eol-style make-transcoder native-transcoder
buffer-mode? file-options-spec)
buffer-mode? file-options-spec transcoder-codec
transcoder-eol-style transcoder-error-handling-mode)
(ikarus system $transcoders))
(define (latin-1-codec) 'latin-1-codec)
(define (utf-8-codec) 'utf-8-codec)
@ -17,6 +19,7 @@
'([ignore . #b01]
[raise . #b10]
[replace . #b11]))
(define error-handling-mode-mask #b11)
(define eol-style-alist
'([none . #b00000]
@ -26,11 +29,19 @@
[nel . #b10000]
[crnel . #b10100]
[ls . #b11000]))
(define eol-style-mask #b11100)
(define codec-alist
'([latin-1-codec . #b0100000]
[utf-8-codec . #b1000000]
[utf-16-codec . #b1100000]))
(define codec-mask #b11100000)
(define (rev-lookup n ls)
(cond
[(null? ls) #f]
[(= (cdar ls) n) (caar ls)]
[else (rev-lookup n (cdr ls))]))
(define (codec->fixnum x who)
(cond
@ -63,6 +74,30 @@
(define (native-transcoder)
(make-transcoder 'utf-8-codec 'none 'replace))
(define (transcoder-codec x)
(define who 'transcoder-codec)
(if ($transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) codec-mask)])
(or (rev-lookup tag codec-alist)
(error who "~s has no codec" x)))
(error who "~s is not a transcoder" x)))
(define (transcoder-eol-style x)
(define who 'transcoder-eol-style)
(if ($transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) eol-style-mask)])
(or (rev-lookup tag eol-style-alist)
(error who "~s has no eol-style" x)))
(error who "~s is not a transcoder" x)))
(define (transcoder-error-handling-mode x)
(define who 'transcoder-error-handling-mode)
(if ($transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) error-handling-mode-mask)])
(or (rev-lookup tag error-handling-mode-alist)
(error who "~s has no error-handling mode" x)))
(error who "~s is not a transcoder" x)))
(define (buffer-mode? x)
(and (memq x '(none line block)) #t))

6
src/makefile.ss
View File

@ -1061,9 +1061,9 @@
[string->bytevector r ip]
[textual-port? r ip]
[transcoded-port r ip]
[transcoder-codec r ip]
[transcoder-eol-style r ip]
[transcoder-error-handling-mode r ip]
[transcoder-codec i r ip]
[transcoder-eol-style i r ip]
[transcoder-error-handling-mode i r ip]
[utf-16-codec i r ip]
[utf-8-codec i r ip]
[input-port? i r is ip se]

6
src/todo-r6rs.ss
View File

@ -637,9 +637,9 @@
[string->bytevector S ip]
[textual-port? S ip]
[transcoded-port S ip]
[transcoder-codec S ip]
[transcoder-eol-style S ip]
[transcoder-error-handling-mode S ip]
[transcoder-codec C ip]
[transcoder-eol-style C ip]
[transcoder-error-handling-mode C ip]
[utf-16-codec C ip]
[utf-8-codec C ip]
;;;