Some compile output still leaks through with --verbosity=1

;;; Copyright © 2019 Mark H Weaver <mhw@netris.org> ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (use-modules (rnrs bytevectors) ;; the following modules are only needed for the test. ;;(srfi srfi-1) ;;(ice-9 iconv) ) ;; Well-formed UTF-8 sequences ;; =========================== ;; 00..7F ;; C2..DF 80..BF ;; E0 *A0..BF 80..BF ;; E1..EC 80..BF 80..BF ;; ED 80..9F* 80..BF ;; EE..EF 80..BF 80..BF ;; F0 *90..BF 80..BF 80..BF ;; F1..F3 80..BF 80..BF 80..BF ;; F4 80..8F* 80..BF 80..BF ;; UTF-8 Decoder states ;; ==================== ;; 0 start state ;; C2 .. DF got 1/2 bytes ;; E0 .. EF got 1/3 bytes ;; F0 .. F4 got 1/4 bytes ;; E0A0 .. ED9F got 2/3 bytes (range 1) ;; EE80 .. EFBF got 2/3 bytes (range 2) ;; F090 .. F48F got 2/4 bytes ;; F09080 .. F48FBF got 3/4 bytes (define-syntax-rule (utf8-decode ((j init-expr) ...) (i continue) (output (code-point) e1 e1* ...) (error (maximal-subpart) e2 e2* ...) state-expr bv-expr start-expr end-expr) ;; The start state is 0. ;; When 'error' is called with arguments (state i j ...), 'state' ;; contains the bytes of the "maximal subpart of an ill-formed ;; subsequence" as defined in The Unicode Standard section 3.9, ;; i.e. the bytes which are being represented by this error report ;; and which are not being converted. 'i' is the bytevector index ;; immediately following this maximal subpart, i.e. the index where ;; decoding should resume. 'j ...' are the user-provided seeds. ;; the decoder returns the values: (new-state bv-pos j ...) (let ((bv bv-expr) (end end-expr)) (define (output code-point i j ...) e1 e1* ...) (define (error maximal-subpart i j ...) e2 e2* ...) (define (continue i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (cond ((<= byte #x7F) (output byte (+ i 1) j ...)) ((<= #xC2 byte #xF4) (got-1 byte (+ i 1) j ...)) (else (error byte (+ i 1) j ...)))) (values 0 i j ...))) (define (got-1 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (cond ((not (<= #x80 byte #xBF)) (error state i j ...)) ((<= state #xDF) (output (logior (ash (logand state #x1F) 6) (logand byte #x3F)) (+ i 1) j ...)) (else (let ((state^ (logior (ash state 8) byte))) (cond ((or (<= #xE0A0 state^ #xED9F) (<= #xEE80 state^ #xEFBF)) (got-2/3 state^ (+ i 1) j ...)) ((<= #xF090 state^ #xF48F) (got-2/4 state^ (+ i 1) j ...)) (else (error state i j ...))))))) (values state i j ...))) (define (got-2/3 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (output (logior (ash (logand state #xF00) 4) (ash (logand state #x3F) 6) (logand byte #x3F)) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (got-2/4 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (got-3/4 (logior (ash state 8) byte) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (got-3/4 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (output (logior (ash (logand state #x70000) 2) (ash (logand state #x3F00) 4) (ash (logand state #x3F) 6) (logand byte #x3F)) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (enter state i j ...) (cond ((zero? state) (continue i j ...)) ((<= state #xF4) (got-1 state i j ...)) ((<= state #xEFBF) (got-2/3 state i j ...)) ((<= state #xF48F) (got-2/4 state i j ...)) (else (got-3/4 state i j ...)))) (enter state-expr start-expr init-expr ...))) ;; Returns three values: (new-state source-pos target-pos) (define (utf8->string! state source source-start source-end target target-start target-end) (utf8-decode ((j target-start)) (i continue) (output (code-point) (string-set! target j (integer->char code-point)) (if (< (+ j 1) target-end) (continue i (+ j 1)) (values 0 i (+ j 1)))) (error (maximal-subpart) (output #xFFFD i j)) ;TODO: support other error handlers state source source-start source-end)) ;; Another experimental primitive, slower than the ones above. (define* (utf8-fold* out err seed state bv #:optional (start 0) (end (bytevector-length bv))) (utf8-decode ((j seed)) (i continue) (output (code-point) (out code-point i j continue)) (error (maximal-subpart) (err maximal-subpart i j continue)) state bv start end)) ;; Another experimental primitive, slower than the ones above. (define* (utf8-fold out err seed state bv #:optional (start 0) (end (bytevector-length bv))) (utf8-fold* (lambda (code-point i j continue) (continue i (out code-point i j))) (lambda (maximal-subpart i j continue) (call-with-values (lambda () (err maximal-subpart i j)) (lambda (continue? j^) (if continue? (continue i j^) (values 0 i j^))))) seed state bv start end)) ;; A not-so-quick test of all valid characters. ;; TODO: Tests of strictness and error handling. #; (let () (define ss (string-tabulate (lambda (i) (if (< i #xD800) (integer->char i) (integer->char (+ i #x800)))) (- #x110000 #x800))) (define bv (string->utf8 ss)) (define bv-len (bytevector-length bv)) (define slen (* 2 (string-length ss))) (define s (make-string slen)) (every (lambda (incr) (string-fill! s #\a) (call-with-values (lambda () (let loop ((state 0) (i 0) (j 0)) (if (< i bv-len) (call-with-values (lambda () (utf8->string! state bv i (min bv-len (+ i incr)) s j slen)) loop) (values state i j)))) (lambda (state i j) (and (= i bv-len) (= j (string-length ss)) (string=? ss (substring s 0 j)))))) (iota 5 1)))

;;; Copyright © 2019 Mark H Weaver <mhw@netris.org> ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (use-modules (rnrs bytevectors) ;; the following modules are only needed for the test. ;;(srfi srfi-1) ;;(ice-9 iconv) ) ;; Well-formed UTF-8 sequences ;; =========================== ;; 00..7F ;; C2..DF 80..BF ;; E0 *A0..BF 80..BF ;; E1..EC 80..BF 80..BF ;; ED 80..9F* 80..BF ;; EE..EF 80..BF 80..BF ;; F0 *90..BF 80..BF 80..BF ;; F1..F3 80..BF 80..BF 80..BF ;; F4 80..8F* 80..BF 80..BF ;; UTF-8 Decoder states ;; ==================== ;; 0 start state ;; C2 .. DF got 1/2 bytes ;; E0 .. EF got 1/3 bytes ;; F0 .. F4 got 1/4 bytes ;; E0A0 .. ED9F got 2/3 bytes (range 1) ;; EE80 .. EFBF got 2/3 bytes (range 2) ;; F090 .. F48F got 2/4 bytes ;; F09080 .. F48FBF got 3/4 bytes (define-syntax-rule (utf8-decode ((j init-expr) ...) (i continue) (output (code-point) e1 e1* ...) (error (maximal-subpart) e2 e2* ...) state-expr bv-expr start-expr end-expr) "Decode part of a UTF-8 byte stream in the bytevector BV-EXPR with indices in the interval from START-EXPR (inclusive) to END-EXPR (exclusive). STATE-EXPR is the initial decoder state, which must be an incomplete prefix of a valid UTF-8 byte sequence. The start state is 0. When a valid UTF-8 byte sequence is found, the output expressions (E1 E1* ...) are evaluated, with the following bindings available in the lexical environment: CODE-POINT the decoded code point, as an exact integer. I bytevector index immediately after the decoded sequence. J ... the user-provided seeds. CONTINUE procedure with arguments (i j ...) to continue decoding. OUTPUT procedure with arguments (code-point i j ...), whose body consists of (E1 E1* ...), provided by the user. ERROR procedure with arguments (maximal-subpart i j ...), whose body consists of (E2 E2* ...), provided by the user. If you wish for decoding to continue, (E1 E1* ...) should end by tail-calling (CONTINUE I J^ ...), where (J^ ...) are the new seeds. Alternatively, if you wish to terminate decoding early, simply return one or more values, which will be returned to the caller of 'utf8-decode'. Normally, (values 0 I J^ ...) should be returned. In case of a decoding error, the expressions (E2 E2* ...) will be called with the same bindings listed above, except CODE-POINT is omitted, and MAXIMAL-SUBPART is bound to the 'maximal subpart of an ill-formed subsequence' as defined in section 3.9 of The Unicode Standard 12.0, i.e. the longest code unit subsequence starting at an inconvertible offset that is either (a) the initial subsequence of a well-formed code unit sequence, or (b) a subsequence of length one. MAXIMAL-SUBPART is represented as an exact integer containing the bytes in big-endian order, e.g. #xF48FBF represents the bytes (F4 8F BF). The bindings OUTPUT and ERROR are provided for convenience, in case the error expressions (E2 E2* ...) wish to call the user-provided output procedure (e.g. to output a substitution character), or the output expressions (E1 E1* ...) wish to call the user-provided error procedure. If the provided bytes in BV-EXPR end with a non-empty but incomplete prefix of a well-formed UTF-8 byte sequence, then the following values are returned: (NEW-STATE BV-POS J ...). When decoding finishes, every byte in the input (including in the initial STATE-EXPR) will have been reported in exactly one of the following ways: (1) as part of a well-formed UTF-8 byte sequence, via the output expressions (E1 E1* ...), or (2) as part of a 'maximal subpart of an ill-formed subsequence', via the error expressions (E2 E2* ...), or (3) as part of the new state. (4) in the unexamined indices of BV-EXPR starting with BV-POS." (let ((bv bv-expr) (end end-expr)) (define (output code-point i j ...) e1 e1* ...) (define (error maximal-subpart i j ...) e2 e2* ...) (define (continue i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (cond ((<= byte #x7F) (output byte (+ i 1) j ...)) ((<= #xC2 byte #xF4) (got-1 byte (+ i 1) j ...)) (else (error byte (+ i 1) j ...)))) (values 0 i j ...))) (define (got-1 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (cond ((not (<= #x80 byte #xBF)) (error state i j ...)) ((<= state #xDF) (output (logior (ash (logand state #x1F) 6) (logand byte #x3F)) (+ i 1) j ...)) (else (let ((state^ (logior (ash state 8) byte))) (cond ((or (<= #xE0A0 state^ #xED9F) (<= #xEE80 state^ #xEFBF)) (got-2/3 state^ (+ i 1) j ...)) ((<= #xF090 state^ #xF48F) (got-2/4 state^ (+ i 1) j ...)) (else (error state i j ...))))))) (values state i j ...))) (define (got-2/3 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (output (logior (ash (logand state #xF00) 4) (ash (logand state #x3F) 6) (logand byte #x3F)) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (got-2/4 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (got-3/4 (logior (ash state 8) byte) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (got-3/4 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (output (logior (ash (logand state #x70000) 2) (ash (logand state #x3F00) 4) (ash (logand state #x3F) 6) (logand byte #x3F)) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (enter state i j ...) (cond ((zero? state) (continue i j ...)) ((<= state #xF4) (got-1 state i j ...)) ((<= state #xEFBF) (got-2/3 state i j ...)) ((<= state #xF48F) (got-2/4 state i j ...)) (else (got-3/4 state i j ...)))) (enter state-expr start-expr init-expr ...))) (define (utf8->string! state source source-start source-end target target-start target-end) "Decode part of a UTF-8 byte stream from the bytevector SOURCE starting at index SOURCE-START and up to (but not including) index SOURCE-END, and writing into the string TARGET starting at index TARGET-START and up to (but not including) index TARGET-END. Returns three values: NEW-STATE, SOURCE-POS, and TARGET-POS. STATE is either 0 (the start state) or the value of NEW-STATE returned by the previous call. In case of errors, each 'maximal subpart of an ill-formed subsequence', as defined in section 3.9 of The Unicode Standard 12.0, is replaced with a Unicode replacement character (U+FFFD)." (if (< target-start target-end) (utf8-decode ((j target-start)) (i continue) (output (code-point) (string-set! target j (integer->char code-point)) (if (< (+ j 1) target-end) (continue i (+ j 1)) (values 0 i (+ j 1)))) (error (maximal-subpart) (output #xFFFD i j)) ;TODO: support other error handlers state source source-start source-end) (values state source-start target-start))) ;; Another experimental primitive, slower than the ones above. (define* (utf8-fold* out err seed state bv #:optional (start 0) (end (bytevector-length bv))) "Decode part of a UTF-8 byte stream from the bytevector SOURCE starting at index SOURCE-START and up to (but not including) index SOURCE-END. Returns three values: NEW-STATE, SOURCE-POS, and FINAL-SEED. STATE is either 0 (the start state) or the value of NEW-STATE returned by the previous call. For each valid code point, call (OUT CODE-POINT SOURCE-POS SEED K), which should either call (K SOURCE-POS NEW-SEED) to continue decoding, or return three values (0 SOURCE-POS NEW-SEED) which will terminate decoding and immediately exit. In case of errors, call (ERR MAXIMAL-SUBPART SOURCE-POS SEED K) where MAXIMAL-SUBPART is a 'maximal subpart of an ill-formed subsequence', as defined in section 3.9 of The Unicode Standard 12.0. Similarly, ERR should either call (K SOURCE-POS NEW-SEED) to continue decoding, or return to exit immediately." (utf8-decode ((j seed)) (i continue) (output (code-point) (out code-point i j continue)) (error (maximal-subpart) (err maximal-subpart i j continue)) state bv start end)) ;; Another experimental primitive, slower than the ones above. (define* (utf8-fold out err seed state bv #:optional (start 0) (end (bytevector-length bv))) "Decode part of a UTF-8 byte stream from the bytevector SOURCE starting at index SOURCE-START and up to (but not including) index SOURCE-END. Returns three values: NEW-STATE, SOURCE-POS, and FINAL-SEED. STATE is either 0 (the start state) or the value of NEW-STATE returned by the previous call. For each valid code point, call (OUT CODE-POINT SOURCE-POS SEED), which should return a new SEED. In case of errors, call (ERR MAXIMAL-SUBPART SOURCE-POS SEED) where MAXIMAL-SUBPART is a 'maximal subpart of an ill-formed subsequence', as defined in section 3.9 of The Unicode Standard 12.0. ERR should return two values: a boolean specifying whether to continue decoding, and a new seed." (utf8-fold* (lambda (code-point i j continue) (continue i (out code-point i j))) (lambda (maximal-subpart i j continue) (call-with-values (lambda () (err maximal-subpart i j)) (lambda (continue? j^) (if continue? (continue i j^) (values 0 i j^))))) seed state bv start end)) ;; A not-so-quick test of all valid characters. ;; TODO: Tests of strictness and error handling. #; (let () (define ss (string-tabulate (lambda (i) (if (< i #xD800) (integer->char i) (integer->char (+ i #x800)))) (- #x110000 #x800))) (define bv (string->utf8 ss)) (define bv-len (bytevector-length bv)) (define slen (* 2 (string-length ss))) (define s (make-string slen)) (every (lambda (incr) (string-fill! s #\a) (call-with-values (lambda () (let loop ((state 0) (i 0) (j 0)) (if (< i bv-len) (call-with-values (lambda () (utf8->string! state bv i (min bv-len (+ i incr)) s j slen)) loop) (values state i j)))) (lambda (state i j) (and (zero? state) (= i bv-len) (= j (string-length ss)) (string=? ss (substring s 0 j)))))) (iota 5 1)))

;;; Copyright © 2019 Mark H Weaver <mhw@netris.org> ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (use-modules (rnrs bytevectors) ;; the following modules are needed only for the test. ;;(srfi srfi-1) ;;(ice-9 iconv) ) ;; Well-formed UTF-8 sequences ;; =========================== ;; 00..7F ;; C2..DF 80..BF ;; E0 *A0..BF 80..BF ;; E1..EC 80..BF 80..BF ;; ED 80..9F* 80..BF ;; EE..EF 80..BF 80..BF ;; F0 *90..BF 80..BF 80..BF ;; F1..F3 80..BF 80..BF 80..BF ;; F4 80..8F* 80..BF 80..BF ;; UTF-8 Decoder states ;; ==================== ;; 0 start state ;; C2 .. DF got 1/2 bytes ;; E0 .. EF got 1/3 bytes ;; F0 .. F4 got 1/4 bytes ;; E0A0 .. ED9F got 2/3 bytes (range 1) ;; EE80 .. EFBF got 2/3 bytes (range 2) ;; F090 .. F48F got 2/4 bytes ;; F09080 .. F48FBF got 3/4 bytes (define-syntax-rule (utf8-decode ((j init-expr) ...) (i continue) (output (code-point) e1 e1* ...) (error (maximal-subpart) e2 e2* ...) state-expr bv-expr start-expr end-expr) "Let BYTE-STR denote the concatenation of the following two byte strings: (1) the bytes encoded in STATE-EXPR, and (2) the bytevector BV-EXPR beginning with index START-EXPR (inclusive) and ending with index END-EXPR (exclusive). STATE-EXPR must evaluate to an exact integer between 0 and #xF48FBF that encodes a proper prefix of a well-formed UTF-8 sequence. The bytes are in big-endian order, e.g. #xF48FBF encodes (F4 8F BF) and 0 encodes the empty string. Let TAIL be the longest suffix of BYTE-STR that is a proper prefix of a well-formed UTF-8 byte sequence. Let ITEMS be a list of strings whose concatenation equals BYTE-STR with TAIL removed, such that each element in ITEMS is either (1) a well-formed UTF-8 byte sequence, or (2) a maximal subpart of an ill-formed subsequence, as defined in section 3.9 of The Unicode Standard 12.0, i.e. the longest code unit subsequence starting at an inconvertible offset that is either (a) the initial subsequence of a well-formed code unit sequence, or (b) a subsequence of length one. UTF8-DECODE iterates over ITEMS from left to right, evaluating the 'output' expressions (E1 E1* ...) for each well-formed UTF-8 byte sequence, and the 'error' expressions (E2 E2* ...) for each maximal subpart of an ill-formed subsequence. As with a 'fold' operation, zero or more seeds are included in the iterator state, bound to variables (J ...) with initial values (INIT-EXPR ...). Each of the user-provided expression sequences (E1 E1* ...) and (E2 E2* ...) have access to the current seed values (J ...), and produce new seed values each time they are called. The user-provided expression sequences have access to the following variables, whose identifiers are specified by operands to UTF8-DECODE: (1) I, the bytevector index immediately following the current item, i.e. where decoding should resume after processing this item. (2) (J ...) the user-provided seed values. (3) CODE-POINT [only bound in (E1 E1* ...)], an exact integer Unicode scalar value. (4) MAXIMAL-SUBPART [only bound in (E2 E2* ...)], the maximal subpart of the ill-formed subsequence, represented as an exact integer from #xC2 to #xF48FBF containing the bytes in big-endian order. For example, #xF48FBF represents the byte string (F4 8F BF). (5) CONTINUE, a procedure which may be applied to arguments (I J^ ...) by the user-provided expression sequences to continue decoding with the new seed values (J^ ...). (6) OUTPUT, a procedure which may be applied to arguments (CODE-POINT I J^ ...) to evaluate the user-provided expression sequence (E1 E1* ...). (7) ERROR, a procedure which may be applied to arguments (MAXIMAL-SUBPART I J^ ...) to evaluate the user-provided expression sequence (E2 E2* ...). Each user-provided expression sequence may choose either to continue the loop by calling (CONTINUE I J^ ...), or to terminate the loop by returning (values 0 I J^ ...), where (J^ ...) are the new seed values. OUTPUT and ERROR are included for convenience, to allow the output and error expression sequences to call each other. For example, it may be convenient for the error expression sequence to end with: (output #xFFFD i j ...) If the end of BYTE-STR is reached, UTF8-DECODE returns the values (NEW-STATE END J^ ...), where NEW-STATE encodes the bytes in TAIL, END equals END-EXPR, and (J^ ...) are the final seed values. In any case, if the user-provided expressions behave as specified above, then when UTF8-DECODE returns values (NEW-STATE NEW-POS J^ ...), every byte in BYTE-STR will have been reported in exactly one of the following ways: (1) as part of a well-formed UTF-8 byte sequence, reported to the user-provided output expressions (E1 E1* ...), or (2) as part of a maximal subpart of an ill-formed subsequence, reported to the user-provided error expressions (E2 E2* ...), or (3) as part of NEW-STATE, or (4) as part of the bytevector starting at index NEW-POS." (let ((bv bv-expr) (end end-expr)) (define (output code-point i j ...) e1 e1* ...) (define (error maximal-subpart i j ...) e2 e2* ...) (define (continue i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (cond ((<= byte #x7F) (output byte (+ i 1) j ...)) ((<= #xC2 byte #xF4) (got-1 byte (+ i 1) j ...)) (else (error byte (+ i 1) j ...)))) (values 0 i j ...))) (define (got-1 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (cond ((not (<= #x80 byte #xBF)) (error state i j ...)) ((<= state #xDF) (output (logior (ash (logand state #x1F) 6) (logand byte #x3F)) (+ i 1) j ...)) (else (let ((state^ (logior (ash state 8) byte))) (cond ((or (<= #xE0A0 state^ #xED9F) (<= #xEE80 state^ #xEFBF)) (got-2/3 state^ (+ i 1) j ...)) ((<= #xF090 state^ #xF48F) (got-2/4 state^ (+ i 1) j ...)) (else (error state i j ...))))))) (values state i j ...))) (define (got-2/3 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (output (logior (ash (logand state #xF00) 4) (ash (logand state #x3F) 6) (logand byte #x3F)) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (got-2/4 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (got-3/4 (logior (ash state 8) byte) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (got-3/4 state i j ...) (if (< i end) (let ((byte (bytevector-u8-ref bv i))) (if (<= #x80 byte #xBF) (output (logior (ash (logand state #x70000) 2) (ash (logand state #x3F00) 4) (ash (logand state #x3F) 6) (logand byte #x3F)) (+ i 1) j ...) (error state i j ...))) (values state i j ...))) (define (enter state i j ...) (cond ((zero? state) (continue i j ...)) ((<= state #xF4) (got-1 state i j ...)) ((<= state #xEFBF) (got-2/3 state i j ...)) ((<= state #xF48F) (got-2/4 state i j ...)) (else (got-3/4 state i j ...)))) (enter state-expr start-expr init-expr ...))) (define (utf8->string! state source source-start source-end target target-start target-end) "Let BYTE-STR denote the concatenation of the following two byte strings: (1) the bytes encoded in STATE, and (2) the bytevector SOURCE beginning with index SOURCE-START (inclusive) and ending with index SOURCE-END (exclusive). STATE must be an exact integer between 0 and #xF48FBF that encodes a proper prefix of a well-formed UTF-8 sequence. The bytes are in big-endian order, e.g. #xF48FBF encodes (F4 8F BF), and 0 encodes the empty string. Let TAIL be the longest suffix of BYTE-STR that is a proper prefix of a well-formed UTF-8 byte sequence, and let BYTE-STR-SANS-TAIL be BYTE-STR with TAIL removed. UTF8->STRING! permissively decodes the Unicode 8-bit string BYTE-STR-SANS-TAIL and writes the resulting characters to the string TARGET beginning with index TARGET-START (inclusive) and ending with index TARGET-END (exclusive). In case of decoding errors, each 'maximal subpart of an ill-formed subsequence', as defined in section 3.9 of The Unicode Standard 12.0, is replaced with a Unicode replacement character (U+FFFD). UTF8->STRING! returns three values (NEW-STATE SOURCE-POS TARGET-POS). If the target string is able to hold all of the decoded characters and replacement characters, then NEW-STATE encodes the bytes in TAIL, SOURCE-POS equals SOURCE-END, and TARGET-POS equals TARGET-START plus the number of characters written. If there's not enough space in the target string, then NEW-STATE is 0, SOURCE-POS is the index of the first byte that is not represented by the characters written, and TARGET-POS equals TARGET-END." (if (< target-start target-end) (utf8-decode ((j target-start)) (i continue) (output (code-point) (string-set! target j (integer->char code-point)) (if (< (+ j 1) target-end) (continue i (+ j 1)) (values 0 i (+ j 1)))) (error (maximal-subpart) (output #xFFFD i j)) ;TODO: support other error handlers state source source-start source-end) (values state source-start target-start))) ;; Another experimental primitive, slower than the ones above. (define* (utf8-fold* out err seed state bv #:optional (start 0) (end (bytevector-length bv))) "Let BYTE-STR denote the concatenation of the following two byte strings: (1) the bytes encoded in STATE, and (2) the bytevector BV beginning with index START (inclusive) and ending with index END (exclusive). STATE must be an exact integer between 0 and #xF48FBF that encodes a proper prefix of a well-formed UTF-8 sequence. The bytes are in big-endian order, e.g. #xF48FBF encodes (F4 8F BF), and 0 encodes the empty string. Let TAIL be the longest suffix of BYTE-STR that is a proper prefix of a well-formed UTF-8 byte sequence. Let ITEMS be a list of strings whose concatenation equals BYTE-STR with TAIL removed, such that each element in ITEMS is either (1) a well-formed UTF-8 byte sequence, or (2) a maximal subpart of an ill-formed subsequence, as defined in section 3.9 of The Unicode Standard 12.0, i.e. the longest code unit subsequence starting at an inconvertible offset that is either (a) the initial subsequence of a well-formed code unit sequence, or (b) a subsequence of length one. UTF8-FOLD* iterates over ITEMS from left to right, calling OUT for each well-formed UTF-8 byte sequence, and ERR for each maximal subpart of an ill-formed subsequence. For each well-formed UTF-8 byte sequence, (OUT CODE-POINT INDEX SEED K) is called, where CODE-POINT is the Unicode scalar value as an exact integer, INDEX is the bytevector index immediately following the decoded code point, SEED is the current seed value, and K is the continuation. OUT may choose to either continue decoding or to exit the loop. To continue decoding, call (K INDEX NEW-SEED). To exit, return (values 0 INDEX FINAL-SEED). For each maximal subpart of an ill-formed UTF-8 byte sequence, (ERR MAXIMAL-SUBPART INDEX SEED K) is called, where MAXIMAL-SUBPART is an exact integer between #xC2 and #xF48FBF containing the bytes in big-endian order, and INDEX is the bytevector index immediately following those bytes. For example, #xF48FBF represents the byte string (F4 8F BF). Like OUT, ERR may either call (K INDEX NEW-SEED) to continue, or return (values 0 INDEX FINAL-SEED) to exit the loop. If the end of BYTE-STR is reached, UTF8-FOLD* returns the values (NEW-STATE END FINAL-SEED), where NEW-STATE encodes the bytes in TAIL. In any case, if the user-provided procedures behave as specified above, then when UTF8-FOLD* returns values (NEW-STATE NEW-POS FINAL-SEED), every byte in BYTE-STR will have been reported in exactly one of the following ways: (1) as part of a well-formed UTF-8 byte sequence, reported to OUT, (2) as part of a maximal subpart of an ill-formed subsequence, reported to ERR, (3) as part of NEW-STATE, or (4) as part of the bytevector starting at index NEW-POS." (utf8-decode ((j seed)) (i continue) (output (code-point) (out code-point i j continue)) (error (maximal-subpart) (err maximal-subpart i j continue)) state bv start end)) ;; Another experimental primitive, slower than the ones above. (define* (utf8-fold out err seed state bv #:optional (start 0) (end (bytevector-length bv))) "Let BYTE-STR denote the concatenation of the following two byte strings: (1) the bytes encoded in STATE, and (2) the bytevector BV beginning with index START (inclusive) and ending with index END (exclusive). STATE must be an exact integer between 0 and #xF48FBF that encodes a proper prefix of a well-formed UTF-8 sequence. The bytes are in big-endian order, e.g. #xF48FBF encodes (F4 8F BF), and 0 encodes the empty string. Let TAIL be the longest suffix of BYTE-STR that is a proper prefix of a well-formed UTF-8 byte sequence. Let ITEMS be a list of strings whose concatenation equals BYTE-STR with TAIL removed, such that each element in ITEMS is either (1) a well-formed UTF-8 byte sequence, or (2) a maximal subpart of an ill-formed subsequence, as defined in section 3.9 of The Unicode Standard 12.0, i.e. the longest code unit subsequence starting at an inconvertible offset that is either (a) the initial subsequence of a well-formed code unit sequence, or (b) a subsequence of length one. UTF8-FOLD iterates over ITEMS from left to right, calling OUT for each well-formed UTF-8 byte sequence, and ERR for each maximal subpart of an ill-formed subsequence. For each well-formed UTF-8 byte sequence, (OUT CODE-POINT INDEX SEED) is called, where CODE-POINT is the Unicode scalar value as an exact integer, INDEX is the bytevector index immediately following the decoded code point, and SEED is the current seed value. OUT should return the new seed value. For each maximal subpart of an ill-formed UTF-8 byte sequence, (ERR MAXIMAL-SUBPART INDEX SEED) is called, where MAXIMAL-SUBPART is an exact integer between #xC2 and #xF48FBF containing the bytes in big-endian order, and INDEX is the bytevector index immediately following those bytes. For example, #xF48FBF represents the byte string (F4 8F BF). ERR should return two values: (CONTINUE? NEW-SEED), where CONTINUE? is a boolean specifying whether to continue the loop. If the end of BYTE-STR is reached, UTF8-FOLD returns the values (NEW-STATE END FINAL-SEED), where NEW-STATE encodes the bytes in TAIL. In any case, if the user-provided procedures behave as specified above, then when UTF8-FOLD returns values (NEW-STATE NEW-POS FINAL-SEED), every byte in BYTE-STR will have been reported in exactly one of the following ways: (1) as part of a well-formed UTF-8 byte sequence, reported to OUT, (2) as part of a maximal subpart of an ill-formed subsequence, reported to ERR, (3) as part of NEW-STATE, or (4) as part of the bytevector starting at index NEW-POS." (utf8-fold* (lambda (code-point i j continue) (continue i (out code-point i j))) (lambda (maximal-subpart i j continue) (call-with-values (lambda () (err maximal-subpart i j)) (lambda (continue? j^) (if continue? (continue i j^) (values 0 i j^))))) seed state bv start end)) ;; A not-so-quick test of all valid characters. ;; TODO: Tests of strictness and error handling. #; (let () (define ss (string-tabulate (lambda (i) (if (< i #xD800) (integer->char i) (integer->char (+ i #x800)))) (- #x110000 #x800))) (define bv (string->utf8 ss)) (define bv-len (bytevector-length bv)) (define slen (* 2 (string-length ss))) (define s (make-string slen)) (every (lambda (incr) (string-fill! s #\a) (call-with-values (lambda () (let loop ((state 0) (i 0) (j 0)) (if (< i bv-len) (call-with-values (lambda () (utf8->string! state bv i (min bv-len (+ i incr)) s j slen)) loop) (values state i j)))) (lambda (state i j) (and (zero? state) (= i bv-len) (= j (string-length ss)) (string=? ss (substring s 0 j)))))) (iota 5 1)))

;;; Copyright © 2019 Mark H Weaver <mhw@netris.org> ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (use-modules (rnrs io ports)) (define (make-custom-textual-output-port id write! get-position set-position! close) (let (;; Allocate a per-port string buffer which will be used as a ;; temporary buffer for decoding, to avoid heap allocation ;; during normal operation. (buffer (make-string 4096)) ;; 'state' is the UTF-8 decoder state, which represents a ;; proper prefix of a well-formed UTF-8 byte sequence. These ;; are bytes that 'binary-write!' has accepted and reported as ;; having been written, although we are not able to decode ;; them into a character to pass to (textual) 'write!' until ;; more bytes arrive. (state 0)) (define (binary-write! bv start count) (call-with-values (lambda () ;; XXX FIXME: Consider performing this ;; decoding strictly. (utf8->string! state bv start (+ start count) buffer 0 (string-length buffer))) (lambda (new-state bv-pos char-count) (let* (;; Avoid calling write! with (char-count = 0) unless ;; (count = 0) was passed to us, because calling ;; 'write!' with count=0 has a special meaning: it ;; means to pass an EOF object to the byte/character ;; sink. (chars-accepted (if (and (zero? char-count) (not (zero? count))) 0 (write! buffer 0 char-count))) ;; Compute 'bytes-accepted' in such a way that the ;; bytes from STATE are not included, because they ;; were passed to us in previous calls, and are not ;; part of the bytevector range that we are now being ;; asked to write. However, it's important to note ;; that if 'write!' did not accept the bytes from ;; STATE, 'bytes-accepted' will be negative. We must ;; handle that case specially below. (bytes-accepted (- count (string-utf8-length (substring buffer chars-accepted char-count))))) ;; If 'bytes-accepted' is negative, that means the bytes ;; from STATE were not written. This can only happen if ;; 'chars-accepted' is 0, because 'write!' can only accept ;; whole code points, and the bytes from STATE are part of ;; at most a single code point. In this case, we must ;; leave STATE unchanged and return 0. (if (negative? bytes-accepted) 0 (begin (set! state new-state) bytes-accepted)))))) (define (binary-close) (set! buffer #f) (when close (close))) (define port (make-custom-binary-output-port id binary-write! get-position set-position! binary-close)) ;; Always use UTF-8 as the encoding for custom textual ports, as ;; an internal implementation detail, to ensure that all Unicode ;; characters will pass through regardless of the current locale. (set-port-encoding! port "UTF-8") port))