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

* Added make-transcoder and native-transcoder

This commit is contained in:
Abdulaziz Ghuloum 2007-10-11 22:55:20 -04:00
parent 0c754c1939
commit aafecc9cfb
7 changed files with 97 additions and 21 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.

62
src/ikarus.codecs.ss
View File

@ -1,9 +1,65 @@
(library (ikarus codecs)
(export latin-1-codec utf-8-codec utf-16-codec native-eol-style)
(import (rnrs base))
(export latin-1-codec utf-8-codec utf-16-codec native-eol-style
make-transcoder native-transcoder)
(import
(except (ikarus) latin-1-codec utf-8-codec utf-16-codec
native-eol-style make-transcoder native-transcoder)
(ikarus system $transcoders))
(define (latin-1-codec) 'latin-1-codec)
(define (utf-8-codec) 'utf-8-codec)
(define (utf-16-codec) 'utf-16-codec)
(define (native-eol-style) 'none))
(define (native-eol-style) 'none)
(define error-handling-mode-alist
'([ignore . #b01]
[raise . #b10]
[replace . #b11]))
(define eol-style-alist
'([none . #b00000]
[lf . #b00100]
[cr . #b01000]
[crlf . #b01100]
[nel . #b10000]
[crnel . #b10100]
[ls . #b11000]))
(define codec-alist
'([latin-1-codec . #b0100000]
[utf-8-codec . #b1000000]
[utf-16-codec . #b1100000]))
(define (codec->fixnum x who)
(cond
[(assq x codec-alist) => cdr]
[else (error who "~s is not a valid coded" x)]))
(define (eol-style->fixnum x who)
(cond
[(assq x eol-style-alist) => cdr]
[else (error who "~s is not a valid eol-style" x)]))
(define (error-handling-mode->fixnum x who)
(cond
[(assq x error-handling-mode-alist) => cdr]
[else (error who "~s is not a valid error-handling mode" x)]))
(define make-transcoder
(case-lambda
[(codec eol-style handling-mode)
($data->transcoder
(fxior
(error-handling-mode->fixnum handling-mode 'make-transcoder)
(eol-style->fixnum eol-style 'make-transcoder)
(codec->fixnum codec 'make-transcoder)))]
[(codec eol-style)
(make-transcoder codec eol-style 'replace)]
[(codec)
(make-transcoder codec 'none 'replace)]))
(define (native-transcoder)
(make-transcoder 'utf-8-codec 'none 'replace))
)

28
src/ikarus.compiler.ss
View File

@ -1829,20 +1829,20 @@
(define disp-code-annotation 16)
(define disp-code-data 24)
(define transcoder-tag #x3F) ;;; 0011
(define transcoder-input-tag #x7F) ;;; 0111
(define transcoder-output-tag #xBF) ;;; 1011
(define transcoder-input/output-tag #xFF) ;;; 1111
(define transcoder-write-utf8-mask #x100)
(define transcoder-write-byte-mask #x200)
(define transcoder-read-utf8-mask #x400)
(define transcoder-read-byte-mask #x800)
(define transcoder-handling-mode-shift 8)
(define transcoder-handling-mode-bits 2)
(define transcoder-eol-style-shift 10)
(define transcoder-eol-style-bits 3)
(define transcoder-codec-shift 13)
(define transcoder-codec-bits 3)
(define transcoder-mask #xFF) ;;; 0011
(define transcoder-tag #x7F) ;;; 0011
(define transcoder-payload-shift 10)
(define transcoder-write-utf8-mask #x1000)
(define transcoder-write-byte-mask #x2000)
(define transcoder-read-utf8-mask #x4000)
(define transcoder-read-byte-mask #x8000)
(define transcoder-handling-mode-shift 16)
(define transcoder-handling-mode-bits 2)
(define transcoder-eol-style-shift 18)
(define transcoder-eol-style-bits 3)
(define transcoder-codec-shift 21)
(define transcoder-codec-bits 3)
(define transcoder-handling-mode:none #b00)
(define transcoder-handling-mode:ignore #b01)

6
src/ikarus.writer.ss
View File

@ -11,6 +11,7 @@
(ikarus system $pairs)
(ikarus system $symbols)
(ikarus system $bytevectors)
(ikarus system $transcoders)
(only (ikarus unicode-data) unicode-printable-char?)
(except (ikarus) write display format printf print-error
error-handler error print-unicode print-graph))
@ -561,6 +562,11 @@
[(number? x)
(write-char* (number->string x) p)
i]
[($transcoder? x)
(write-char* "#<transcoder " p)
(let ([n ($transcoder->data x)])
(write-char* (number->string n) p))
(write-char* ">" p)]
[else
(write-char* "#<unknown>" p)
i])))

8
src/makefile.ss
View File

@ -178,6 +178,7 @@
[$flonums (ikarus system $flonums) #f #t]
[$bignums (ikarus system $bignums) #f #t]
[$bytes (ikarus system $bytevectors) #f #t]
[$transc (ikarus system $transcoders) #f #t]
[$fx (ikarus system $fx) #f #t]
[$rat (ikarus system $ratnums) #f #t]
[$symbols (ikarus system $symbols) #f #t]
@ -1029,9 +1030,9 @@
[make-i/o-read-error r ip is fi]
[make-i/o-write-error r ip is fi]
[latin-1-codec i r ip]
[make-transcoder r ip]
[make-transcoder i r ip]
[native-eol-style i r ip]
[native-transcoder r ip]
[native-transcoder i r ip]
[open-bytevector-input-port r ip]
[open-bytevector-output-port r ip]
[open-file-input-port r ip]
@ -1194,6 +1195,9 @@
[module i cm]
[syntax-dispatch ]
[syntax-error i sc]
[$transcoder? $transc]
[$transcoder->data $transc]
[$data->transcoder $transc]
))
(define (macro-identifier? x)

10
src/pass-specify-rep-primops.ss
View File

@ -1656,4 +1656,14 @@
/section)
(section ; transcoders
(define-primop $transcoder? unsafe
[(P x) (tag-test (T x) transcoder-mask transcoder-tag)])
(define-primop $data->transcoder unsafe
[(V x) (prm 'logor
(prm 'sll (T x) (K (- transcoder-payload-shift fixnum-shift)))
(K transcoder-tag))])
(define-primop $transcoder->data unsafe
[(V x) (prm 'sra (T x) (K (- transcoder-payload-shift fixnum-shift)))])
/section)

4
src/todo-r6rs.ss
View File

@ -608,9 +608,9 @@
[make-i/o-read-error X ip is fi]
[make-i/o-write-error X ip is fi]
[latin-1-codec C ip]
[make-transcoder S ip]
[make-transcoder C ip]
[native-eol-style C ip]
[native-transcoder S ip]
[native-transcoder C ip]
[open-bytevector-input-port S ip]
[open-bytevector-output-port S ip]
[open-file-input-port S ip]