#| -*-Scheme-*-

$Id: unicode.scm,v 1.25 2005/12/13 15:29:52 cph Exp $

Copyright 2001,2003,2004,2005 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Unicode support
;;; package: (runtime unicode)

;;; See "http://www.cl.cam.ac.uk/~mgk25/unicode.html".
;;;
;;; UTF-8 encoding
;;; ==============
;;;
;;;  max code  encoding
;;; ---------- -----------------------------------------------------
;;; #x00000080 0xxxxxxx
;;; #x00000800 110xxxxx 10xxxxxx
;;; #x00010000 1110xxxx 10xxxxxx 10xxxxxx
;;; #x00200000 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
;;; #x04000000 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
;;; #x80000000 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
;;;
;;; It is possible to represent codes with over-long sequences, but
;;; this is disallowed.  For example, #\A is normally represented as
;;; #x41, but could also be written as #xC1 #x81, or even longer
;;; sequences.
;;;
;;; Additionally, the codes #xD800 through #xDFFF, #xFFFE, and #xFFFF
;;; are disallowed, as they are not valid Unicode characters.
;;;
;;; UTF-16 encoding
;;; ===============
;;;
;;; Codes in the ranges #x0000 through #xD7FF and #xE000 through
;;; #xFFFD are represented as themselves.  Codes in the range #x10000
;;; through #xFFFFF are represented as a pair:
;;;
;;; 110110xxxxxxxxxx 110111xxxxxxxxxx
;;;
;;; where the first 16-bit word contains the MS 10 bits, and the
;;; second contains the LS 10 bits.  As for UTF-8, overlong sequences
;;; are disallowed.
;;;
;;; Some UTF-16 documents start with the code #xFEFF, to identify the
;;; endianness of the document.  If instead #xFFFE is encountered, the
;;; opposite endianness should be used.

(declare (usual-integrations))

(define-syntax with-substring-args
  (sc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '(expression expression expression expression
				     + expression)
			(cdr form))
	 (let ((string (close-syntax (list-ref form 1) environment))
	       (start (close-syntax (list-ref form 2) environment))
	       (end (close-syntax (list-ref form 3) environment))
	       (caller (close-syntax (list-ref form 4) environment)))
	   `(BEGIN
	      (GUARANTEE-STRING ,string ,caller)
	      (LET* ((,(list-ref form 3)
		      (IF (IF (DEFAULT-OBJECT? ,end) #F ,end)
			  (GUARANTEE-LIMITED-INDEX ,end (STRING-LENGTH ,string)
						   ,caller)
			  (STRING-LENGTH ,string)))
		     (,(list-ref form 2)
		      (IF (IF (DEFAULT-OBJECT? ,start) #F ,start)
			  (GUARANTEE-LIMITED-INDEX ,start ,(list-ref form 3)
						   ,caller)
			  0)))
		,@(map (let ((excludes
			      (list (list-ref form 2) (list-ref form 3))))
			 (lambda (expr)
			   (make-syntactic-closure environment excludes expr)))
		       (list-tail form 5)))))
	 (ill-formed-syntax form)))))

(define (encoded-string-length string start end type caller validate-char)
  (let loop ((start start) (n 0))
    (if (fix:< start end)
	(let ((start* (validate-char string start end)))
	  (if (not start*)
	      (error:wrong-type-argument string
					 (string-append "a UTF-"
							type
							" string")
					 caller))
	  (loop start* (fix:+ n 1)))
	n)))

(define (encoded-string-valid? string start end validate-char)
  (let loop ((start start))
    (if (fix:< start end)
	(let ((start* (validate-char string start end)))
	  (if start*
	      (loop start*)
	      #f))
	#t)))

(define (port->byte-source port)
  (lambda ()
    (let ((char (read-char port)))
      (if (eof-object? char)
	  #f
	  (let ((b (char->integer char)))
	    (if (not (fix:< b #x100))
		(error "Illegal input byte:" b))
	    b)))))

(define (port->byte-sink port)
  (lambda (byte)
    (write-char (integer->char byte) port)))

;;;; Unicode characters

(define (wide-char? object)
  (and (char? object)
       (fix:= (char-bits object) 0)
       (unicode-code-point? (char-code object))))

(define-guarantee wide-char "a Unicode character")

(define (unicode-code-point? object)
  (and (index-fixnum? object)
       (legal-code-32? object)))

(define-guarantee unicode-code-point "a Unicode code point")

(define-integrable (legal-code-32? pt)
  (if (fix:< pt #x10000)
      (legal-code-16? pt)
      (fix:< pt char-code-limit)))

(define-integrable (legal-code-16? pt)
  (not (illegal-code-16? pt)))

(define-integrable (illegal-code-16? pt)
  (or (fix:= #xD800 (fix:and #xF800 pt))
      (fix:= #xFFFE (fix:and #xFFFE pt))))

;;;; Alphabets

(define-structure (alphabet (type-descriptor <alphabet>))
  (low #f read-only #t)
  (high1 #f read-only #t)
  (high2 #f read-only #t))

(define-guarantee alphabet "a Unicode alphabet")

(define-integrable (make-alphabet-low)
  (make-string #x100 (integer->char 0)))

(define-integrable (alphabet-low-ref low code-point)
  (not (fix:= (fix:and (vector-8b-ref low (fix:lsh code-point -3))
		       (fix:lsh 1 (fix:and code-point 7)))
	      0)))

(define-integrable (alphabet-low-set! low code-point)
  (vector-8b-set! low
		  (fix:lsh code-point -3)
		  (fix:or (vector-8b-ref low (fix:lsh code-point -3))
			  (fix:lsh 1 (fix:and code-point 7)))))

(define null-alphabet
  (make-alphabet (make-alphabet-low) '#() '#()))

(define (char-in-alphabet? char alphabet)
  (guarantee-wide-char char 'CHAR-IN-ALPHABET?)
  (guarantee-alphabet alphabet 'CHAR-IN-ALPHABET?)
  (%code-point-in-alphabet? (char-code char) alphabet))

(define (%code-point-in-alphabet? pt alphabet)
  (if (fix:< pt #x800)
      (alphabet-low-ref (alphabet-low alphabet) pt)
      (let ((high1 (alphabet-high1 alphabet))
	    (high2 (alphabet-high2 alphabet)))
	(let loop ((lower 0) (upper (vector-length high1)))
	  (and (fix:< lower upper)
	       (let ((index (fix:quotient (fix:+ lower upper) 2)))
		 (cond ((fix:< pt (vector-ref high1 index))
			(loop lower index))
		       ((fix:< (vector-ref high2 index) pt)
			(loop (fix:+ index 1) upper))
		       (else #t))))))))

(define (well-formed-code-point-list? items)
  (if (pair? items)
      (and (well-formed-item? (car items))
	   (let loop ((a (car items)) (items (cdr items)))
	     (or (not (pair? items))
		 (let ((b (car items))
		       (items (cdr items)))
		   (and (well-formed-item? b)
			(fix:< (if (pair? a) (cdr a) a)
			       (if (pair? b) (car b) b))
			(loop b items))))))
      (null? items)))

(define (well-formed-item? item)
  (if (pair? item)
      (and (unicode-code-point? (car item))
	   (unicode-code-point? (cdr item))
	   (fix:< (car item) (cdr item)))
      (unicode-code-point? item)))

(define-guarantee well-formed-code-point-list "a Unicode code-point list")

(define (code-points->alphabet items)
  (guarantee-well-formed-code-point-list items 'CODE-POINTS->ALPHABET)
  (%code-points->alphabet items))

(define (%code-points->alphabet items)
  (receive (low-items high-items) (split-list items #x800)
    (let ((low (make-alphabet-low)))
      (for-each (lambda (item)
		  (if (pair? item)
		      (do ((i (car item) (fix:+ i 1)))
			  ((fix:> i (cdr item)))
			(alphabet-low-set! low i))
		      (alphabet-low-set! low item)))
		low-items)
      (let ((n-high (length high-items)))
	(let ((high1 (make-vector n-high))
	      (high2 (make-vector n-high)))
	  (do ((items high-items (cdr items))
	       (i 0 (fix:+ i 1)))
	      ((not (pair? items)))
	    (if (pair? (car items))
		(begin
		  (vector-set! high1 i (caar items))
		  (vector-set! high2 i (cdar items)))
		(begin
		  (vector-set! high1 i (car items))
		  (vector-set! high2 i (car items)))))
	  (make-alphabet low high1 high2))))))

(define (split-list items limit)
  (let loop ((items items) (low '()))
    (if (pair? items)
	(let ((item (car items)))
	  (cond ((not (pair? item))
		 (if (fix:< item limit)
		     (loop (cdr items) (cons item low))
		     (values low items)))
		((fix:< (cdr item) limit)
		 (loop (cdr items) (cons item low)))
		((fix:<= limit (car item))
		 (values low items))
		(else
		 (values (cons (cons (car item) (- limit 1)) low)
			 (cons (cons limit (cdr item)) items)))))
	(values low '()))))

(define (alphabet . chars)
  (%code-points->alphabet (chars->wfcp-list (remove-duplicate-chars chars))))

(define (remove-duplicate-chars chars)
  (let ((table (make-eq-hash-table)))
    (for-each (lambda (char)
		(guarantee-wide-char char 'REMOVE-DUPLICATE-CHARS)
		(hash-table/put! table char #t))
	      chars)
    (hash-table/key-list table)))

(define (chars->wfcp-list chars)
  (let ((chars (sort chars char<?)))
    (if (pair? chars)
	(let loop
	    ((pt (char->integer (car chars)))
	     (chars (cdr chars))
	     (items '()))
	  (if (pair? chars)
	      (let ((pt* (char->integer (car chars)))
		    (chars (cdr chars)))
		(if (fix:= pt* (fix:+ pt 1))
		    (let find-max ((pt* pt*) (chars chars))
		      (if (pair? chars)
			  (let ((pt** (char->integer (car chars)))
				(chars (cdr chars)))
			    (if (fix:= pt** (fix:+ pt* 1))
				(find-max pt** chars)
				(loop pt** chars (cons (cons pt pt*) items))))
			  (reverse! (cons (cons pt pt*) items))))
		    (loop pt* chars (cons pt items))))
	      (reverse! (cons pt items))))
	'())))

(define (alphabet->code-points alphabet)
  (guarantee-alphabet alphabet 'ALPHABET->CODE-POINTS)
  (append! (alphabet-low->code-points (alphabet-low alphabet))
	   (alphabet-high->code-points (alphabet-high1 alphabet)
				       (alphabet-high2 alphabet))))

(define (alphabet-low->code-points low)
  (let find-lower ((i 0) (result '()))
    (if (fix:< i #x800)
	(if (alphabet-low-ref low i)
	    (let ((lower i))
	      (let find-upper ((i (fix:+ i 1)))
		(if (fix:< i #x800)
		    (if (alphabet-low-ref low i)
			(find-upper (fix:+ i 1))
			(find-lower i
				    (cons (if (fix:= lower (fix:- i 1))
					      lower
					      (cons lower (fix:- i 1)))
					  result)))
		    (reverse!
		     (cons (if (fix:= lower (fix:- i 1))
			       lower
			       (cons lower (fix:- i 1)))
			   result)))))
	    (find-lower (fix:+ i 1) result))
	(reverse! result))))

(define (alphabet-high->code-points lower upper)
  (let ((n (vector-length lower)))
    (let loop ((i 0) (result '()))
      (if (fix:< i n)
	  (loop (fix:+ i 1)
		(cons (cons (vector-ref lower i) (vector-ref upper i))
		      result))
	  (reverse! result)))))

(define (8-bit-alphabet? alphabet)
  (and (fix:= (vector-length (alphabet-high1 alphabet)) 0)
       (let ((low (alphabet-low alphabet)))
	 (let loop ((i #x20))
	   (or (fix:= i #x100)
	       (and (fix:= (vector-8b-ref low i) 0)
		    (loop (fix:+ i 1))))))))

(define-guarantee 8-bit-alphabet "an 8-bit alphabet")

(define (char-set->alphabet char-set)
  (guarantee-char-set char-set 'CHAR-SET->ALPHABET)
  (let ((low (make-alphabet-low)))
    (do ((i 0 (fix:+ i 1)))
	((fix:= i #x100))
      (if (char-set-member? char-set (integer->char i))
	  (alphabet-low-set! low i)))
    (make-alphabet low '#() '#())))

(define (alphabet->char-set alphabet)
  (guarantee-8-bit-alphabet alphabet 'ALPHABET->CHAR-SET)
  (predicate->char-set (lambda (char) (char-in-alphabet? char alphabet))))

(define (string->alphabet string)
  (guarantee-string string 'STRING->ALPHABET)
  (let ((n (string-length string))
	(low (make-alphabet-low)))
    (do ((i 0 (fix:+ i 1)))
	((fix:= i n))
      (alphabet-low-set! low (vector-8b-ref string i)))
    (make-alphabet low '#() '#())))

(define (alphabet->string alphabet)
  (guarantee-8-bit-alphabet alphabet 'ALPHABET->STRING)
  (let loop ((i 0) (chars '()))
    (if (fix:< i #x100)
	(loop (fix:+ i 1)
	      (if (%code-point-in-alphabet? i alphabet)
		  (cons (integer->char i) chars)
		  chars))
	(apply string (reverse! chars)))))

(define (alphabet+ . alphabets)
  (for-each (lambda (alphabet)
	      (guarantee-alphabet alphabet 'ALPHABET+))
	    alphabets)
  (reduce alphabet+2 null-alphabet alphabets))

(define (alphabet+2 a1 a2)
  (receive (high1 high2)
      (alphabet-high+2 (alphabet-high1 a1)
		       (alphabet-high2 a1)
		       (alphabet-high1 a2)
		       (alphabet-high2 a2))
    (make-alphabet (alphabet-low+2 (alphabet-low a1) (alphabet-low a2))
		   high1
		   high2)))

(define (alphabet-low+2 low1 low2)
  (let ((low (make-alphabet-low)))
    (do ((i 0 (fix:+ i 1)))
	((fix:= i #x100))
      (vector-8b-set! low i
		      (fix:or (vector-8b-ref low1 i)
			      (vector-8b-ref low2 i))))
    low))

(define (alphabet-high+2 lower1 upper1 lower2 upper2)
  (let ((n1 (vector-length lower1))
	(n2 (vector-length lower2)))
    (let ((lower (make-vector (fix:+ n1 n2)))
	  (upper (make-vector (fix:+ n1 n2))))
      (let ((n
	     (let loop ((i1 0) (i2 0) (i 0))
	       (cond ((fix:= i1 n1)
		      (subvector-move-left! lower2 i2 n2 lower i)
		      (subvector-move-left! upper2 i2 n2 upper i)
		      (fix:+ i (fix:- n2 i2)))
		     ((fix:= i2 n2)
		      (subvector-move-left! lower1 i1 n1 lower i)
		      (subvector-move-left! upper1 i1 n1 upper i)
		      (fix:+ i (fix:- n1 i1)))
		     ((fix:< (vector-ref upper1 i1) (vector-ref lower2 i2))
		      (vector-set! lower i (vector-ref lower1 i1))
		      (vector-set! upper i (vector-ref upper1 i1))
		      (loop (fix:+ i1 1) i2 (fix:+ i 1)))
		     ((fix:< (vector-ref upper2 i2) (vector-ref lower1 i1))
		      (vector-set! lower i (vector-ref lower2 i2))
		      (vector-set! upper i (vector-ref upper2 i2))
		      (loop i1 (fix:+ i2 1) (fix:+ i 1)))
		     (else
		      (vector-set! lower i
				   (min (vector-ref lower1 i1)
					(vector-ref lower2 i2)))
		      (vector-set! upper i
				   (max (vector-ref upper1 i1)
					(vector-ref upper2 i2)))
		      (loop (fix:+ i1 1) (fix:+ i2 1) (fix:+ i 1)))))))
	(if (fix:< n (vector-length lower))
	    (values (vector-head lower n) (vector-head upper n))
	    (values lower upper))))))

(define (alphabet- a1 a2)
  (receive (high1 high2)
      (alphabet-high- (alphabet-high1 a1)
		      (alphabet-high2 a1)
		      (alphabet-high1 a2)
		      (alphabet-high2 a2))
    (make-alphabet (alphabet-low- (alphabet-low a1) (alphabet-low a2))
		   high1
		   high2)))

(define (alphabet-low- low1 low2)
  (let ((low (make-alphabet-low)))
    (do ((i 0 (fix:+ i 1)))
	((fix:= i #x100))
      (vector-8b-set! low i
		      (fix:and (vector-8b-ref low1 i)
			       (fix:not (vector-8b-ref low2 i)))))
    low))

(define (alphabet-high- lower1 upper1 lower2 upper2)
  (let ((n1 (vector-length lower1))
	(n2 (vector-length lower2)))
    (let ((lower (make-vector (fix:* n1 2)))
	  (upper (make-vector (fix:* n1 2))))
      (let ((n
	     (let loop ((i1 0) (i2 0) (i 0))
	       (cond ((fix:= i1 n1)
		      i)
		     ((fix:= i2 n2)
		      (subvector-move-left! lower1 i1 n1 lower i)
		      (subvector-move-left! upper1 i1 n1 upper i)
		      (fix:+ i (fix:- n1 i1)))
		     ((fix:< (vector-ref upper1 i1) (vector-ref lower2 i2))
		      (vector-set! lower i (vector-ref lower1 i1))
		      (vector-set! upper i (vector-ref upper1 i1))
		      (loop (fix:+ i1 1) i2 (fix:+ i 1)))
		     ((fix:< (vector-ref upper2 i2) (vector-ref lower1 i1))
		      (loop i1 (fix:+ i2 1) i))
		     ((fix:< (vector-ref lower1 i1) (vector-ref lower2 i2))
		      (vector-set! lower i (vector-ref lower1 i1))
		      (vector-set! upper i (- (vector-ref lower2 i2) 1))
		      (if (fix:<= (vector-ref upper1 i1)
				  (vector-ref upper2 i2))
			  (loop (fix:+ i1 1) (fix:+ i2 1) (fix:+ i 1))
			  (begin
			    (vector-set! lower (fix:+ i 1)
					 (+ (vector-ref upper2 i2) 1))
			    (vector-set! upper (fix:+ i 1)
					 (vector-ref upper1 i1))
			    (loop (fix:+ i1 1) (fix:+ i2 1) (fix:+ i 2)))))
		     ((fix:<= (vector-ref upper1 i1) (vector-ref upper2 i2))
		      (loop (fix:+ i1 1) (fix:+ i2 1) i))
		     (else
		      (vector-set! lower i (+ (vector-ref upper2 i2) 1))
		      (vector-set! upper i (vector-ref upper1 i1))
		      (loop (fix:+ i1 1) (fix:+ i2 1) (fix:+ i 1)))))))
	(if (fix:< n (vector-length lower))
	    (values (vector-head lower n) (vector-head upper n))
	    (values lower upper))))))

;;;; Unicode strings

(define-structure (wide-string (type-descriptor <wide-string>)
			       (constructor %make-wide-string))
  (contents #f read-only #t))

(define-guarantee wide-string "a Unicode string")

(define (make-wide-string length #!optional char)
  (%make-wide-string
   (make-vector length
		(if (if (default-object? char) #f char)
		    (begin
		      (guarantee-wide-char char 'MAKE-WIDE-STRING)
		      char)
		    (integer->char 0)))))

(define (wide-string . chars)
  (for-each (lambda (char) (guarantee-wide-char char 'WIDE-STRING)) chars)
  (%make-wide-string (list->vector chars)))

(define (wide-string-length string)
  (guarantee-wide-string string 'WIDE-STRING-LENGTH)
  (%wide-string-length string))

(define-integrable (%wide-string-length string)
  (vector-length (wide-string-contents string)))

(define (wide-string-ref string index)
  (guarantee-wide-string string 'WIDE-STRING-REF)
  (guarantee-wide-string-index index string 'WIDE-STRING-REF)
  (%wide-string-ref string index))

(define-integrable (%wide-string-ref string index)
  (vector-ref (wide-string-contents string) index))

(define (wide-string-set! string index char)
  (guarantee-wide-string string 'WIDE-STRING-SET!)
  (guarantee-wide-string-index index string 'WIDE-STRING-SET!)
  (guarantee-wide-char char 'WIDE-STRING-SET!)
  (%wide-string-set! string index char))

(define-integrable (%wide-string-set! string index char)
  (vector-set! (wide-string-contents string) index char))

(define (wide-substring string start end)
  (guarantee-wide-substring string start end 'WIDE-SUBSTRING)
  (%wide-substring string start end))

(define (%wide-substring string start end)
  (let ((string* (make-wide-string (fix:- end start))))
    (let ((v1 (wide-string-contents string))
	  (v2 (wide-string-contents string*)))
      (do ((i start (fix:+ i 1))
	   (j 0 (fix:+ j 1)))
	  ((not (fix:< i end)))
	(vector-set! v2 j (vector-ref v1 i))))
    string*))

(define (wide-string-index? index string)
  (and (index-fixnum? index)
       (fix:< index (%wide-string-length string))))

(define-integrable (guarantee-wide-string-index index string caller)
  (if (not (wide-string-index? index string))
      (error:not-wide-string-index index caller)))

(define (error:not-wide-string-index index caller)
  (error:wrong-type-argument index "a Unicode string index" caller))

(define-integrable (guarantee-wide-substring string start end caller)
  (if (not (and (wide-string? string)
		(index-fixnum? start)
		(index-fixnum? end)
		(fix:<= start end)
		(fix:<= end (%wide-string-length string))))
      (guarantee-wide-substring/fail string start end caller)))

(define (guarantee-wide-substring/fail string start end caller)
  (guarantee-wide-string string caller)
  (guarantee-limited-index end (%wide-string-length string) caller)
  (guarantee-limited-index start end caller))

(define (string->wide-string string #!optional start end)
  (guarantee-string string 'STRING->WIDE-STRING)
  (let* ((end
	  (if (if (default-object? end) #f end)
	      (guarantee-limited-index end (string-length string)
				       'STRING->WIDE-STRING)
	      (string-length string)))
	 (start
	  (if (if (default-object? start) #f start)
	      (guarantee-limited-index start end 'STRING->WIDE-STRING)
	      0))
	 (v (make-vector (fix:- end start))))
    (do ((i start (fix:+ i 1))
	 (j 0 (fix:+ j 1)))
	((not (fix:< i end)))
      (vector-set! v j (string-ref string i)))
    (%make-wide-string v)))

(define (wide-string->string string #!optional start end)
  (guarantee-wide-string string 'WIDE-STRING->STRING)
  (let* ((v (wide-string-contents string))
	 (end
	  (if (if (default-object? end) #f end)
	      (guarantee-limited-index end (vector-length v)
				       'WIDE-STRING->STRING)
	      (vector-length v)))
	 (start
	  (if (if (default-object? start) #f start)
	      (guarantee-limited-index start end 'WIDE-STRING->STRING)
	      0))
	 (s (make-string (fix:- end start))))
    (do ((i start (fix:+ i 1))
	 (j 0 (fix:+ j 1)))
	((not (fix:< i end)))
      (if (fix:< (char->integer (vector-ref v i)) #x100)
	  (string-set! s j (vector-ref v i))
	  (error:bad-range-argument string 'WIDE-STRING->STRING)))
    s))

;;;; UTF-32 representation

(define (source-utf32-be-char source caller)
  (source-utf32-char source utf32-be-bytes->code-point caller))

(define (source-utf32-le-char source caller)
  (source-utf32-char source utf32-le-bytes->code-point caller))

(define-integrable (source-utf32-char source combiner caller)
  (let ((b0 (source)))
    (and b0
	 (let* ((b1 (source))
		(b2 (source))
		(b3 (source)))
	   (if (not (and b1 b2 b3))
	       (error "Truncated UTF-32 input."))
	   (let ((pt (combiner b0 b1 b2 b3)))
	     (if (not (legal-code-32? pt))
		 (error:not-unicode-code-point pt caller))
	     (integer->char pt))))))

(define-integrable (utf32-be-bytes->code-point b0 b1 b2 b3)
  (+ (* b0 #x01000000)
     (fix:lsh b1 16)
     (fix:lsh b2 8)
     b3))

(define-integrable (utf32-le-bytes->code-point b0 b1 b2 b3)
  (+ (* b3 #x01000000)
     (fix:lsh b2 16)
     (fix:lsh b1 8)
     b0))

(define-integrable (sink-utf32-be-char char sink)
  (let ((pt (char->integer char)))
    (sink 0)
    (sink (fix:lsh pt -16))
    (sink (fix:lsh pt -8))
    (sink (fix:and pt #xFF))))

(define-integrable (sink-utf32-le-char char sink)
  (let ((pt (char->integer char)))
    (sink (fix:and pt #xFF))
    (sink (fix:lsh pt -8))
    (sink (fix:lsh pt -16))
    (sink 0)))

(define (utf32-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end
			   (if (host-big-endian?)
			       source-utf32-be-char
			       source-utf32-le-char)
			   'UTF32-STRING->WIDE-STRING))

(define (utf32-be-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end source-utf32-be-char
			   'UTF32-BE-STRING->WIDE-STRING))

(define (utf32-le-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end source-utf32-le-char
			   'UTF32-LE-STRING->WIDE-STRING))

(define (wide-string->utf32-string string #!optional start end)
  (wide-string->utf-string string start end
			   (if (host-big-endian?)
			       sink-utf32-be-char
			       sink-utf32-le-char)
			   'WIDE-STRING->UTF32-STRING))

(define (wide-string->utf32-be-string string #!optional start end)
  (wide-string->utf-string string start end sink-utf32-be-char
			   'WIDE-STRING->UTF32-BE-STRING))

(define (wide-string->utf32-le-string string #!optional start end)
  (wide-string->utf-string string start end sink-utf32-le-char
			   'WIDE-STRING->UTF32-LE-STRING))

(define (utf32-string-length string #!optional start end)
  (if (host-big-endian?)
      (%utf32-string-length string start end "32BE" utf32-be-bytes->code-point
			    'UTF32-STRING-LENGTH)
      (%utf32-string-length string start end "32LE" utf32-le-bytes->code-point
			    'UTF32-STRING-LENGTH)))

(define (utf32-be-string-length string #!optional start end)
  (%utf32-string-length string start end "32BE" utf32-be-bytes->code-point
			'UTF32-BE-STRING-LENGTH))

(define (utf32-le-string-length string #!optional start end)
  (%utf32-string-length string start end "32LE" utf32-le-bytes->code-point
			'UTF32-LE-STRING-LENGTH))

(define (%utf32-string-length string start end type combiner caller)
  (with-substring-args string start end caller
    (encoded-string-length string start end type caller
      (lambda (string start end)
	(validate-utf32-char string start end combiner)))))

(define (utf32-string-valid? string #!optional start end)
  (%utf32-string-valid? string start end
			(if (host-big-endian?)
			    utf32-be-bytes->code-point
			    utf32-le-bytes->code-point)
			'UTF32-STRING-VALID?))

(define (utf32-be-string-valid? string #!optional start end)
  (%utf32-string-valid? string start end utf32-be-bytes->code-point
			'UTF32-BE-STRING-VALID?))

(define (utf32-le-string-valid? string #!optional start end)
  (%utf32-string-valid? string start end utf32-le-bytes->code-point
			'UTF32-LE-STRING-VALID?))

(define (%utf32-string-valid? string start end combiner caller)
  (with-substring-args string start end caller
    (encoded-string-valid? string start end
      (lambda (string start end)
	(validate-utf32-char string start end combiner)))))

(define (validate-utf32-char string start end combiner)

  (define-integrable (n i)
    (vector-8b-ref string (fix:+ start i)))

  (if (fix:< start end)
      (and (fix:<= (fix:+ start 4) end)
	   (legal-code-32? (combiner (n 0) (n 1) (n 2) (n 3)))
	   (fix:+ start 4))
      start))

(define (utf32-string? object)
  (and (string? object)
       (utf32-string-valid? object)))

(define (utf32-be-string? object)
  (and (string? object)
       (utf32-be-string-valid? object)))

(define (utf32-le-string? object)
  (and (string? object)
       (utf32-le-string-valid? object)))

(define-guarantee utf32-string "UTF-32 string")
(define-guarantee utf32-be-string "UTF-32BE string")
(define-guarantee utf32-le-string "UTF-32LE string")

;;;; UTF-16 representation

(define (source-utf16-be-char source caller)
  (source-utf16-char source be-bytes->digit16 caller))

(define (source-utf16-le-char source caller)
  (source-utf16-char source le-bytes->digit16 caller))

(define-integrable (source-utf16-char source combinator caller)
  (let ((d0 (source-utf16-digit source combinator)))
    (and d0
	 (integer->char
	  (if (high-surrogate? d0)
	      (let ((d1 (source-utf16-digit source combinator)))
		(if (not d1)
		    (error "Truncated UTF-16 input."))
		(if (not (low-surrogate? d1))
		    (error "Illegal UTF-16 subsequent digit:" d1))
		(combine-surrogates d0 d1))
	      (begin
		(if (illegal-code-16? d0)
		    (error:not-unicode-code-point d0 caller))
		d0))))))

(define-integrable (source-utf16-digit source combinator)
  (let ((b0 (source)))
    (and b0
	 (let ((b1 (source)))
	   (if (not b1)
	       (error "Truncated UTF-16 input."))
	   (combinator b0 b1)))))

(define-integrable (sink-utf16-be-char char sink)
  (sink-utf16-char char sink
		   (lambda (digit sink)
		     (sink (fix:lsh digit -8))
		     (sink (fix:and digit #x00FF)))))

(define-integrable (sink-utf16-le-char char sink)
  (sink-utf16-char char sink
		     (lambda (digit sink)
		       (sink (fix:and digit #x00FF))
		       (sink (fix:lsh digit -8)))))

(define-integrable (sink-utf16-char char sink dissecter)
  (let ((pt (char->integer char)))
    (if (fix:< pt #x10000)
	(dissecter pt sink)
	(let ((s (fix:- pt #x10000)))
	  (dissecter (fix:or #xD800 (fix:lsh s -10)) sink)
	  (dissecter (fix:or #xDC00 (fix:and s #x3FF)) sink)))))

(define (utf16-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end
			   (if (host-big-endian?)
			       source-utf16-be-char
			       source-utf16-le-char)
			   'UTF16-STRING->WIDE-STRING))

(define (utf16-be-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end source-utf16-be-char
			   'UTF16-BE-STRING->WIDE-STRING))

(define (utf16-le-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end source-utf16-le-char
			   'UTF16-LE-STRING->WIDE-STRING))

(define (wide-string->utf16-string string #!optional start end)
  (wide-string->utf-string string start end
			   (if (host-big-endian?)
			       sink-utf16-be-char
			       sink-utf16-le-char)
			   'WIDE-STRING->UTF16-STRING))

(define (wide-string->utf16-be-string string #!optional start end)
  (wide-string->utf-string string start end sink-utf16-be-char
			   'WIDE-STRING->UTF16-BE-STRING))

(define (wide-string->utf16-le-string string #!optional start end)
  (wide-string->utf-string string start end sink-utf16-le-char
			   'WIDE-STRING->UTF16-LE-STRING))

(define (utf16-string-length string #!optional start end)
  (if (host-big-endian?)
      (%utf16-string-length string start end "16BE" be-bytes->digit16
			    'UTF16-STRING-LENGTH)
      (%utf16-string-length string start end "16LE" le-bytes->digit16
			    'UTF16-STRING-LENGTH)))

(define (utf16-be-string-length string #!optional start end)
  (%utf16-string-length string start end "16BE" be-bytes->digit16
			'UTF16-BE-STRING-LENGTH))

(define (utf16-le-string-length string #!optional start end)
  (%utf16-string-length string start end "16LE" le-bytes->digit16
			'UTF16-LE-STRING-LENGTH))

(define (%utf16-string-length string start end type combiner caller)
  (with-substring-args string start end caller
    (encoded-string-length string start end type caller
      (lambda (string start end)
	(validate-utf16-char string start end combiner)))))

(define (utf16-string-valid? string #!optional start end)
  (if (host-big-endian?)
      (%utf16-string-valid? string start end be-bytes->digit16
			    'UTF16-STRING-VALID?)
      (%utf16-string-valid? string start end le-bytes->digit16
			    'UTF16-STRING-VALID?)))

(define (utf16-be-string-valid? string #!optional start end)
  (%utf16-string-valid? string start end be-bytes->digit16
			'UTF16-BE-STRING-VALID?))

(define (utf16-le-string-valid? string #!optional start end)
  (%utf16-string-valid? string start end le-bytes->digit16
			'UTF16-LE-STRING-VALID?))

(define (%utf16-string-valid? string start end combiner caller)
  (with-substring-args string start end caller
    (encoded-string-valid? string start end
      (lambda (string start end)
	(validate-utf16-char string start end combiner)))))

(define (validate-utf16-char string start end combiner)

  (define-integrable (n i)
    (vector-8b-ref string (fix:+ start i)))

  (if (fix:< start end)
      (and (fix:<= (fix:+ start 2) end)
	   (let ((d0 (combiner (n 0) (n 1))))
	     (if (high-surrogate? d0)
		 (and (fix:<= (fix:+ start 4) end)
		      (low-surrogate? (combiner (n 2) (n 3)))
		      (fix:+ start 4))
		 (and (legal-code-16? d0)
		      (fix:+ start 2)))))
      start))

(define-integrable (be-bytes->digit16 b0 b1)
  (fix:or (fix:lsh b0 8) b1))

(define-integrable (le-bytes->digit16 b0 b1)
  (fix:or (fix:lsh b1 8) b0))

(define-integrable (high-surrogate? n)
  (fix:= #xD800 (fix:and #xFC00 n)))

(define-integrable (low-surrogate? n)
  (fix:= #xDC00 (fix:and #xFC00 n)))

(define-integrable (combine-surrogates n0 n1)
  (fix:+ (fix:+ (fix:lsh (fix:and n0 #x3FF) 10)
		(fix:and n1 #x3FF))
	 #x10000))

(define (utf16-string? object)
  (and (string? object)
       (utf16-string-valid? object)))

(define (utf16-be-string? object)
  (and (string? object)
       (utf16-be-string-valid? object)))

(define (utf16-le-string? object)
  (and (string? object)
       (utf16-le-string-valid? object)))

(define-guarantee utf16-string "UTF-16 string")
(define-guarantee utf16-be-string "UTF-16BE string")
(define-guarantee utf16-le-string "UTF-16LE string")

;;;; UTF-8 representation

(define (source-utf8-char source caller)
  (let ((b0 (source))
	(get-next
	 (lambda ()
	   (let ((b (source)))
	     (if (not b)
		 (error "Truncated UTF-8 input."))
	     (if (not (%valid-trailer? b))
		 (error "Illegal subsequent UTF-8 byte:" b))
	     b))))
    (and b0
	 (integer->char
	  (cond ((fix:< b0 #x80)
		 b0)
		((fix:< b0 #xE0)
		 (%vc2 b0)
		 (%cp2 b0 (get-next)))
		((fix:< b0 #xF0)
		 (let ((b1 (get-next)))
		   (%vc3 b0 b1)
		   (let ((pt (%cp3 b0 b1 (get-next))))
		     (if (illegal-code-16? pt)
			 (error:not-unicode-code-point pt caller))
		     pt)))
		((fix:< b0 #xF8)
		 (let ((b1 (get-next)))
		   (%vc4 b0 b1)
		   (let ((b2 (get-next)))
		     (%cp4 b0 b1 b2 (get-next)))))
		(else
		 (error "Illegal UTF-8 byte:" b0)))))))

(define (utf8-string->wide-string string #!optional start end)
  (utf-string->wide-string string start end
			   source-utf8-char
			   'UTF8-STRING->WIDE-STRING))

(define (sink-utf8-char char sink)
  (let ((pt (char->integer char)))

    (define-integrable (initial-char n-bits offset)
      (fix:or (fix:and (fix:lsh #xFF (fix:+ n-bits 1)) #xFF)
	      (fix:lsh pt (fix:- 0 offset))))

    (define-integrable (subsequent-char offset)
      (fix:or #x80 (fix:and (fix:lsh pt (fix:- 0 offset)) #x3F)))

    (cond ((fix:< pt #x00000080)
	   (sink pt))
	  ((fix:< pt #x00000800)
	   (sink (initial-char 5 6))
	   (sink (subsequent-char 0)))
	  ((fix:< pt #x00010000)
	   (sink (initial-char 4 12))
	   (sink (subsequent-char 6))
	   (sink (subsequent-char 0)))
	  (else
	   (sink (initial-char 3 18))
	   (sink (subsequent-char 12))
	   (sink (subsequent-char 6))
	   (sink (subsequent-char 0))))))

(define (wide-string->utf8-string string #!optional start end)
  (wide-string->utf-string string start end
			   sink-utf8-char
			   'WIDE-STRING->UTF8-STRING))

(define (utf8-string-length string #!optional start end)
  (with-substring-args string start end 'UTF8-STRING-LENGTH
    (encoded-string-length string start end "8" 'UTF8-STRING-LENGTH
			   validate-utf8-char)))

(define (utf8-string-valid? string #!optional start end)
  (with-substring-args string start end 'UTF8-STRING-VALID?
    (encoded-string-valid? string start end validate-utf8-char)))

(define (utf8-string? object)
  (and (string? object)
       (utf8-string-valid? object)))

(define-guarantee utf8-string "UTF-8 string")

(define (string->utf8-string string #!optional start end)
  (with-substring-args string start end 'STRING->UTF8-STRING
    (let ((string*
	   (make-string
	    (fix:+ (fix:- end start)
		   (let loop ((i start) (n 0))
		     (if (fix:< i end)
			 (loop (fix:+ i 1)
			       (if (fix:< (vector-8b-ref string i) #x80)
				   n
				   (fix:+ n 1)))
			 n))))))
      (let loop ((i start) (i* 0))
	(if (fix:< i end)
	    (if (fix:< (vector-8b-ref string i) #x80)
		(begin
		  (vector-8b-set! string* i* (vector-8b-ref string i))
		  (loop (fix:+ i 1) (fix:+ i* 1)))
		(begin
		  (vector-8b-set!
		   string*
		   i*
		   (fix:or #xC0 (fix:lsh (vector-8b-ref string i) -6)))
		  (vector-8b-set!
		   string*
		   (fix:+ i* 1)
		   (fix:or #x80 (fix:and (vector-8b-ref string i) #x3F)))
		  (loop (fix:+ i 1) (fix:+ i* 2))))))
      string*)))

(define (validate-utf8-char string start end)

  (define-integrable (check-byte i)
    (%valid-trailer? (n i)))

  (define-integrable (n i)
    (vector-8b-ref string (fix:+ start i)))

  (if (fix:< start end)
      (let ((b0 (vector-8b-ref string start)))
	(cond ((fix:< b0 #x80)
	       (fix:+ start 1))
	      ((fix:< b0 #xE0)
	       (and (fix:<= (fix:+ start 2) end)
		    (check-byte 1)
		    (%vs2 b0)
		    (fix:+ start 2)))
	      ((fix:< b0 #xF0)
	       (and (fix:<= (fix:+ start 3) end)
		    (check-byte 1)
		    (check-byte 2)
		    (%vs3 b0 (n 1))
		    (legal-code-16? (%cp3 b0 (n 1) (n 2)))
		    (fix:+ start 3)))
	      ((fix:< b0 #xF8)
	       (and (fix:<= (fix:+ start 4) end)
		    (check-byte 1)
		    (%vs4 b0 (n 1))
		    (check-byte 2)
		    (check-byte 3)
		    (fix:+ start 4)))
	      (else #f)))
      start))

(define-integrable (%vc2 b0)
  (if (not (%vs2 b0))
      (error "Illegal UTF-8 sequence:" b0)))

(define-integrable (%vc3 b0 b1)
  (if (not (%vs3 b0 b1))
      (error "Illegal UTF-8 sequence:" b0 b1)))

(define-integrable (%vc4 b0 b1)
  (if (not (%vs4 b0 b1))
      (error "Illegal UTF-8 sequence:" b0 b1)))

(define-integrable (%vs2 b0)
  (fix:> b0 #xC1))

(define-integrable (%vs3 b0 b1)
  (or (fix:> b0 #xE0) (fix:> b1 #x9F)))

(define-integrable (%vs4 b0 b1)
  (or (fix:> b0 #xF0) (fix:> b1 #x8F)))

(define-integrable (%cp2 b0 b1)
  (fix:or (fix:lsh (fix:and b0 #x1F) 6)
	  (fix:and b1 #x3F)))

(define-integrable (%cp3 b0 b1 b2)
  (fix:or (fix:lsh (fix:and b0 #x0F) 12)
	  (fix:or (fix:lsh (fix:and b1 #x3F) 6)
		  (fix:and b2 #x3F))))

(define-integrable (%cp4 b0 b1 b2 b3)
  (fix:or (fix:lsh (fix:and b0 #x07) 18)
	  (fix:or (fix:lsh (fix:and b1 #x3F) 12)
		  (fix:or (fix:lsh (fix:and b2 #x3F) 6)
			  (fix:and b3 #x3F)))))

(define-integrable (%valid-trailer? n)
  (fix:= #x80 (fix:and #xC0 n)))

;;;; Wide string ports

(define open-wide-output-string)
(define open-wide-input-string)

(define (initialize-package!)
  (set! open-wide-output-string
	(let ((type
	       (make-port-type
		`((WRITE-CHAR
		   ,(lambda (port char)
		      (guarantee-wide-char char 'WRITE-CHAR)
		      ((port/state port) char)
		      1))
		  (EXTRACT-OUTPUT
		   ,(lambda (port)
		      (%make-wide-string
		       (get-output-objects (port/state port)))))
		  (EXTRACT-OUTPUT!
		   ,(lambda (port)
		      (%make-wide-string
		       (get-output-objects! (port/state port)))))
		  (WRITE-SELF
		   ,(lambda (port port*)
		      port
		      (write-string " to wide string" port*))))
		#f)))
	  (lambda ()
	    (make-port type (open-output-object-buffer)))))
  (set! open-wide-input-string
	(let ((type
	       (make-port-type
		`((READ-CHAR
		   ,(lambda (port)
		      (or ((port/state port))
			  (make-eof-object port))))
		  (WRITE-SELF
		   ,(lambda (port output-port)
		      port
		      (write-string " from wide string" output-port))))
		#f)))
	  (lambda (string #!optional start end)
	    (guarantee-wide-string string 'OPEN-WIDE-INPUT-STRING)
	    (make-port type
		       (open-input-object-buffer (wide-string-contents string)
						 start
						 end
						 'OPEN-WIDE-INPUT-STRING)))))
  unspecific)

(define (call-with-wide-output-string generator)
  (let ((port (open-wide-output-string)))
    (generator port)
    (get-output-string port)))

(define (utf-string->wide-string string start end source-char caller)
  (let ((source (open-input-byte-buffer string start end caller)))
    (%make-wide-string
     (call-with-output-object-buffer
      (lambda (sink)
	(let loop ()
	  (let ((char (source-char source caller)))
	    (if char
		(begin
		  (sink char)
		  (loop))))))))))

(define (wide-string->utf-string string start end sink-char caller)
  (let ((source
	 (open-input-object-buffer (wide-string-contents string) start end
				   caller)))
    (call-with-output-byte-buffer
     (lambda (sink)
       (let loop ()
	 (let ((char (source)))
	   (if char
	       (begin
		 (sink-char char sink)
		 (loop)))))))))

;;;; Byte buffers

(define (open-output-byte-buffer)
  (let ((bytes #f)
	(index))
    (lambda (byte)
      (case byte
	((EXTRACT-OUTPUT)
	 (if bytes
	     (string-head bytes index)
	     (make-string 0)))
	((EXTRACT-OUTPUT!)
	  (without-interrupts
	   (lambda ()
	     (if bytes
		 (let ((bytes* bytes))
		   (set! bytes #f)
		   (set-string-maximum-length! bytes* index)
		   bytes*)
		 (make-string 0)))))
	(else
	 (without-interrupts
	  (lambda ()
	    (cond ((not bytes)
		   (set! bytes (make-string 128))
		   (set! index 0))
		  ((not (fix:< index (string-length bytes)))
		   (let ((bytes*
			  (make-string (fix:* (string-length bytes) 2))))
		     (string-move! bytes bytes* 0)
		     (set! bytes bytes*))))
	    (vector-8b-set! bytes index byte)
	    (set! index (fix:+ index 1))
	    unspecific)))))))

(define (get-output-bytes buffer) (buffer 'EXTRACT-OUTPUT))
(define (get-output-bytes! buffer) (buffer 'EXTRACT-OUTPUT!))

(define (call-with-output-byte-buffer generator)
  (let ((buffer (open-output-byte-buffer)))
    (generator buffer)
    (get-output-bytes buffer)))

(define (open-input-byte-buffer bytes start end caller)
  (let* ((end
	  (if (if (default-object? end) #f end)
	      (guarantee-limited-index end (string-length bytes) caller)
	      (string-length bytes)))
	 (index
	  (if (if (default-object? start) #f start)
	      (guarantee-limited-index start end caller)
	      0)))
    (lambda ()
      (without-interrupts
       (lambda ()
	 (and (fix:< index end)
	      (let ((byte (vector-8b-ref bytes index)))
		(set! index (fix:+ index 1))
		byte)))))))

;;;; Object buffers

(define (open-output-object-buffer)
  (let ((objects #f)
	(index))
    (lambda (object)
      (cond ((eq? object extract-output-tag)
	     (if objects
		 (vector-head objects index)
		 (make-vector 0)))
	    ((eq? object extract-output!-tag)
	     (without-interrupts
	      (lambda ()
		(if objects
		    (let ((objects* objects))
		      (set! objects #f)
		      (if (fix:< index (vector-length objects*))
			  (vector-head objects* index)
			  objects*))
		    (make-vector 0)))))
	    (else
	     (without-interrupts
	      (lambda ()
		(cond ((not objects)
		       (set! objects (make-vector 128))
		       (set! index 0))
		      ((not (fix:< index (vector-length objects)))
		       (set! objects
			     (vector-grow objects
					  (fix:* (vector-length objects) 2)))))
		(vector-set! objects index object)
		(set! index (fix:+ index 1))
		unspecific)))))))

(define (get-output-objects buffer) (buffer extract-output-tag))
(define (get-output-objects! buffer) (buffer extract-output!-tag))

(define extract-output-tag (list 'EXTRACT-OUTPUT))
(define extract-output!-tag (list 'EXTRACT-OUTPUT!))

(define (call-with-output-object-buffer generator)
  (let ((buffer (open-output-object-buffer)))
    (generator buffer)
    (get-output-objects buffer)))

(define (open-input-object-buffer objects start end caller)
  (let* ((end
	  (if (if (default-object? end) #f end)
	      (guarantee-limited-index end (vector-length objects) caller)
	      (vector-length objects)))
	 (index
	  (if (if (default-object? start) #f start)
	      (guarantee-limited-index start end caller)
	      0)))
    (lambda ()
      (without-interrupts
       (lambda ()
	 (and (fix:< index end)
	      (let ((object (vector-ref objects index)))
		(set! index (fix:+ index 1))
		object)))))))

(define (guarantee-limited-index index limit caller)
  (guarantee-index-fixnum index caller)
  (if (not (fix:<= index limit))
      (error:bad-range-argument index caller))
  index)