OSCL/closure-common
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Use 21 bit characters on Lisp offering them.

Browse Source
This commit is contained in:
dlichteblau
2007-12-22 15:19:25 +00:00
parent 2a41e7611f
commit 5cd8915297
4 changed files with 95 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
closure-common.asd
View File

@ -15,19 +15,31 @@
(let (#+sbcl (*compile-print* nil))
(call-next-method))))
#-(or rune-is-character rune-is-integer)
(progn
(format t "~&;;; Checking for wide character support...")
(force-output)
(pushnew (dotimes (x 65536
(progn
(format t " ok, characters have at least 16 bits.~%")
:rune-is-character))
(unless (or (<= #xD800 x #xDFFF)
(and (< x char-code-limit) (code-char x)))
(flet ((test (code)
(and (< code char-code-limit) (code-char code))))
(cond
((not (test 50000))
(format t " no, reverting to octet strings.~%")
(return :rune-is-integer)))
*features*))
#+rune-is-character
(error "conflicting unicode configuration. Please recompile.")
(pushnew :rune-is-integer *features*))
((code-char 70000)
(when (test #xD800)
(format t " WARNING: Lisp implementation doesn't use UTF-16, ~
but accepts surrogate code points.~%"))
(format t " yes, using code points.~%")
#+(or rune-is-integer rune-is-utf-16)
(error "conflicting unicode configuration. Please recompile.")
(pushnew :rune-is-character *features*))
(t
(format t " yes, using UTF-16.~%")
#+(or rune-is-integer (and rune-is-character (not rune-is-utf-16)))
(error "conflicting unicode configuration. Please recompile.")
(pushnew :rune-is-utf-16 *features*)
(pushnew :rune-is-character *features*)))))
#-rune-is-character
(format t "~&;;; Building Closure with (UNSIGNED-BYTE 16) RUNES~%")

77
encodings.lisp
View File

@ -1,5 +1,10 @@
(in-package :runes-encoding)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter +buffer-byte+
#+rune-is-utf-16 '(unsigned-byte 16)
#-rune-is-utf-16 '(unsigned-byte 32)))
(define-condition encoding-error (simple-error) ())
(defun xerror (fmt &rest args)
@ -82,7 +87,7 @@
(defun make-simple-8-bit-encoding (&key charset)
(make-instance 'simple-8-bit-encoding
:table (coerce (to-unicode-table charset) '(simple-array (unsigned-byte 16) (256)))))
:table (coerce (to-unicode-table charset) '(simple-array #.+buffer-byte+ (256)))))
;;;;;;;
@ -150,16 +155,30 @@
(return))
(when (>= (%+ rptr 1) in-end)
(return))
(let ((hi (aref in rptr))
(lo (aref in (%+ 1 rptr))))
(setf rptr (%+ 2 rptr))
;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste
;; Zeichen abwarten und nachgucken, dass nicht etwa die andere
;; Haelfte fehlt!
(let ((x (logior (ash hi 8) lo)))
(let* ((hi (aref in rptr))
(lo (aref in (%+ 1 rptr)))
(x (logior (ash hi 8) lo)))
(when (or (eql x #xFFFE) (eql x #xFFFF))
(xerror "not a valid code point: #x~X" x))
(setf (aref out wptr) x))
(when (<= #xDC00 x #xDFFF)
(xerror "unexpected high surrogate: #x~X" x))
(when (<= #xD800 x #xDBFF)
;; seen low surrogate, look for high surrogate now
(when (>= (%+ rptr 3) in-end)
(return))
(let* ((hi2 (aref in (%+ 2 rptr)))
(lo2 (aref in (%+ 3 rptr)))
(y (logior (ash hi2 8) lo2)))
(unless (<= #xDC00 x #xDFFF)
(xerror "expected a high surrogate but found: #x~X" x))
#-rune-is-utf-16
(progn
(setf x (logior (ash (%- x #xd7c0) 10) (%and y #x3FF)))
(setf rptr (%+ 2 rptr))))
;; end of surrogate handling
)
(setf (aref out wptr) x)
(setf rptr (%+ 2 rptr))
(setf wptr (%+ 1 wptr))))
(values wptr rptr)))
@ -173,16 +192,30 @@
(return))
(when (>= (%+ rptr 1) in-end)
(return))
(let ((lo (aref in (%+ 0 rptr)))
(hi (aref in (%+ 1 rptr))))
(setf rptr (%+ 2 rptr))
;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste
;; Zeichen abwarten und nachgucken, dass nicht etwa die andere
;; Haelfte fehlt!
(let ((x (logior (ash hi 8) lo)))
(let* ((lo (aref in rptr))
(hi (aref in (%+ 1 rptr)))
(x (logior (ash hi 8) lo)))
(when (or (eql x #xFFFE) (eql x #xFFFF))
(xerror "not a valid code point: #x~X" x))
(setf (aref out wptr) x))
(when (<= #xDC00 x #xDFFF)
(xerror "unexpected high surrogate: #x~X" x))
(when (<= #xD800 x #xDBFF)
;; seen low surrogate, look for high surrogate now
(when (>= (%+ rptr 3) in-end)
(return))
(let* ((lo2 (aref in (%+ 2 rptr)))
(hi2 (aref in (%+ 3 rptr)))
(y (logior (ash hi2 8) lo2)))
(unless (<= #xDC00 x #xDFFF)
(xerror "expected a high surrogate but found: #x~X" x))
#-rune-is-utf-16
(progn
(setf x (logior (ash (%- x #xd7c0) 10) (%and y #x3FF)))
(setf rptr (%+ 2 rptr))))
;; end of surrogate handling
)
(setf (aref out wptr) x)
(setf rptr (%+ 2 rptr))
(setf wptr (%+ 1 wptr))))
(values wptr rptr)))
@ -190,7 +223,8 @@
in in-start in-end out out-start out-end eof?)
(declare (optimize (speed 3) (safety 0))
(type (simple-array (unsigned-byte 8) (*)) in)
(type (simple-array (unsigned-byte 16) (*)) out)
(type (simple-array #.+buffer-byte+ (*))
out)
(type fixnum in-start in-end out-start out-end))
(let ((wptr out-start)
(rptr in-start)
@ -204,6 +238,7 @@
(eql x #xFFFE)
(eql x #xFFFF))
(xerror "not a valid code point: #x~X" x))
#+rune-is-utf-16
((%> x #xFFFF)
(setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10))
(aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF)))
@ -325,7 +360,7 @@
eof?)
(declare (optimize (speed 3) (safety 0))
(type (simple-array (unsigned-byte 8) (*)) in)
(type (simple-array (unsigned-byte 16) (*)) out)
(type (simple-array #.+buffer-byte+ (*)) out)
(type fixnum in-start in-end out-start out-end))
(let ((wptr out-start)
(rptr in-start)
@ -333,7 +368,7 @@
(table (slot-value encoding 'table)))
(declare (type fixnum wptr rptr)
(type (unsigned-byte 8) byte)
(type (simple-array (unsigned-byte 16) (*)) table))
(type (simple-array #.+buffer-byte+ (*)) table))
(loop
(when (%= wptr out-end) (return))
(when (%>= rptr in-end) (return))
@ -387,7 +422,7 @@
:name ',name
:to-unicode-table
',(make-array 256
:element-type '(unsigned-byte 16)
:element-type '#.+buffer-byte+
:initial-contents codes)))
',name))

5
xstream.lisp
View File

@ -83,7 +83,10 @@
`(unsigned-byte ,(integer-length array-total-size-limit)))
(deftype buffer-byte ()
`(unsigned-byte 16))
#+rune-is-utf-16
`(unsigned-byte 16)
#-rune-is-utf-16
`(unsigned-byte 32))
(deftype octet ()
`(unsigned-byte 8))

13
ystream.lisp
View File

@ -76,14 +76,17 @@
(when (plusp ptr)
(let* ((in (ystream-in-buffer ystream))
(out (ystream-out-buffer ystream))
#+rune-is-utf-16
(surrogatep (<= #xD800 (rune-code (elt in (1- ptr))) #xDBFF))
n)
#+rune-is-utf-16
(when surrogatep
(decf ptr))
(when (plusp ptr)
(setf n (runes-to-utf8 out in ptr))
(ystream-device-write ystream out n)
(cond
#+rune-is-utf-16
(surrogatep
(setf (elt in 0) (elt in (1- ptr)))
(setf (ystream-in-ptr ystream) 1))
@ -98,7 +101,7 @@
(macrolet ((define-utf8-writer (name (byte &rest aux) result &body body)
`(defun ,name (out in n)
(let ((high-surrogate nil)
(let (#+rune-is-utf-16 (high-surrogate nil)
,@aux)
(labels
((write0 (,byte)
@ -134,13 +137,19 @@
(write0 (logior #b10000000 (ldb (byte 6 0) r))))))
(write2 (r)
(cond
#+rune-is-utf-16
((<= #xD800 r #xDBFF)
(setf high-surrogate r))
#+rune-is-utf-16
((<= #xDC00 r #xDFFF)
(let ((q (logior (ash (- high-surrogate #xD7C0) 10)
(- r #xDC00))))
(write1 q))
(setf high-surrogate nil))
#-rune-is-utf-16
((<= #xD800 r #xDFFF)
(error
"surrogates not allowed in this configuration"))
(t
(write1 r)))))
(dotimes (j n)
@ -259,7 +268,7 @@
(defun utf8-string-to-rod (str)
(let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))
(buffer (make-array (length bytes) :element-type '(unsigned-byte 16)))
(buffer (make-array (length bytes) :element-type 'buffer-byte))
(n (runes-encoding:decode-sequence
:utf-8 bytes 0 (length bytes) buffer 0 0 nil))
(result (make-array n :element-type 'rune)))