Add support for UTF-32.

diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index 392ecbc5d0e23ed877ffe36fad719fe61f4759f9..bc6b8c077176be3fade4485a7444c08d176f57bb 100644 (file)
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.23 2004/02/17 04:59:29 cph Exp $
+$Id: genio.scm,v 1.24 2004/02/23 20:49:32 cph Exp $
 
 Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology
 Copyright 2003,2004 Massachusetts Institute of Technology
@@ -1267,6 +1267,60 @@ USA.
                 (extract n1 #x3FF 0))
         #x10000))
 \f
+(define-decoder 'UTF-32-BE
+  (lambda (ib)
+    (let ((bv (input-buffer-bytes ib))
+         (bs (input-buffer-start ib)))
+      (and (fix:<= (fix:+ bs 4) (input-buffer-end ib))
+          (let ((cp
+                 (+ (* (get-byte bv bs 0) #x1000000)
+                    (* (get-byte bv bs 1) #x10000)
+                    (* (get-byte bv bs 2) #x100)
+                    (get-byte bv bs 3))))
+            (if (unicode-code-point? cp)
+                (begin
+                  (set-input-buffer-start! ib (fix:+ bs 4))
+                  cp)
+                (error:char-decoding ib)))))))
+
+(define-decoder 'UTF-32-LE
+  (lambda (ib)
+    (let ((bv (input-buffer-bytes ib))
+         (bs (input-buffer-start ib)))
+      (and (fix:<= (fix:+ bs 4) (input-buffer-end ib))
+          (let ((cp
+                 (+ (* (get-byte bv bs 3) #x1000000)
+                    (* (get-byte bv bs 2) #x10000)
+                    (* (get-byte bv bs 1) #x100)
+                    (get-byte bv bs 0))))
+            (if (unicode-code-point? cp)
+                (begin
+                  (set-input-buffer-start! ib (fix:+ bs 4))
+                  cp)
+                (error:char-decoding ib)))))))
+
+(define-encoder 'UTF-32-BE
+  (lambda (ob cp)
+    (if (fix:< cp #x110000)
+       (let ((bv (output-buffer-bytes ob))
+             (bs (output-buffer-start ob)))
+         (put-byte bv bs 0 #x00)
+         (put-byte bv bs 1 (fix:and (fix:lsh cp #x10) #xFF))
+         (put-byte bv bs 2 (fix:and (fix:lsh cp #x08) #xFF))
+         (put-byte bv bs 3 (fix:and cp #xFF)))
+       (error:char-encoding ob cp))))
+
+(define-encoder 'UTF-32-LE
+  (lambda (ob cp)
+    (if (fix:< cp #x110000)
+       (let ((bv (output-buffer-bytes ob))
+             (bs (output-buffer-start ob)))
+         (put-byte bv bs 0 (fix:and cp #xFF))
+         (put-byte bv bs 1 (fix:and (fix:lsh cp #x08) #xFF))
+         (put-byte bv bs 2 (fix:and (fix:lsh cp #x10) #xFF))
+         (put-byte bv bs 3 #x00))
+       (error:char-encoding ob cp))))
+\f
 ;;;; Normalizers
 
 (define-normalizer 'NEWLINE