diff --git a/src/ikarus.boot b/src/ikarus.boot index 49d0972..e458fb7 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.codecs.ss b/src/ikarus.codecs.ss index c5742f1..2627249 100644 --- a/src/ikarus.codecs.ss +++ b/src/ikarus.codecs.ss @@ -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)) + + ) diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 2eeb9e6..c61e734 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -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) diff --git a/src/ikarus.writer.ss b/src/ikarus.writer.ss index 3aa7b4b..35a8fe7 100644 --- a/src/ikarus.writer.ss +++ b/src/ikarus.writer.ss @@ -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* "#data x)]) + (write-char* (number->string n) p)) + (write-char* ">" p)] [else (write-char* "#" p) i]))) diff --git a/src/makefile.ss b/src/makefile.ss index 8b5a99a..a15e287 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -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) diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index 2150792..decc0a8 100644 --- a/src/pass-specify-rep-primops.ss +++ b/src/pass-specify-rep-primops.ss @@ -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) diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index f2e43cb..9483210 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -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]