Skip to content
Snippets Groups Projects
Commit eb4a0079 authored by rtoy's avatar rtoy
Browse files

strategy.lisp:

o Add single-channel and dual-channel functions to write strings.  This
  allows proper handling of strings with surrogates.

rt/simple-streams-test.lisp:
o Add test for writing a large string with surrogate characters.
parent 9c4ee94e
No related branches found
No related tags found
No related merge requests found
...@@ -512,3 +512,24 @@ ...@@ -512,3 +512,24 @@
(let ((seq (read-line s))) (let ((seq (read-line s)))
(string= string seq)))) (string= string seq))))
t) t)
#+unicode
(deftest unicode-write-large-1
;; Tests if writing unicode surrogates work
(let ((string (concatenate 'string
(map 'string #'code-char '(#xd800 #xdc00))
(make-string 5000 :initial-element #\X))))
(with-open-file (s *test-file*
:class 'file-simple-stream
:direction :output
:if-exists :supersede
:if-does-not-exist :create
:external-format :utf8)
(write-string string s))
(with-open-file (s *test-file*
:direction :input
:if-does-not-exist :error
:external-format :utf8)
(let ((seq (read-line s)))
(string= string seq))))
t)
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; domain. ;;; domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.16 2009/07/23 04:26:58 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.17 2009/07/23 15:47:21 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -128,7 +128,9 @@ ...@@ -128,7 +128,9 @@
(bref (sm buffer stream) ptr)))) (bref (sm buffer stream) ptr))))
;;;; ;;;;
#+(or)
(defconstant +ef-obs-oc+ 0) (defconstant +ef-obs-oc+ 0)
#+(or)
(defconstant +ef-obs-co+ 1) (defconstant +ef-obs-co+ 1)
#+(or) #+(or)
...@@ -174,6 +176,7 @@ ...@@ -174,6 +176,7 @@
(defconstant +ss-ef-wchars+ 3) (defconstant +ss-ef-wchars+ 3)
(defconstant +ss-ef-max+ 4) (defconstant +ss-ef-max+ 4)
;; Read one character from a simple-stream.
(def-ef-macro %read-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchar+) (def-ef-macro %read-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchar+)
`(lambda (stream max refill) `(lambda (stream max refill)
(declare (type simple-stream stream) (declare (type simple-stream stream)
...@@ -189,6 +192,7 @@ ...@@ -189,6 +192,7 @@
(incf (sm buffpos stream))) (incf (sm buffpos stream)))
(lambda (n) (decf (sm buffpos stream) n)))))) (lambda (n) (decf (sm buffpos stream) n))))))
;; Read many characters from a simple-stream and place them in a string.
(def-ef-macro %read-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchars+) (def-ef-macro %read-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchars+)
`(lambda (stream string search start end max refill) `(lambda (stream string search start end max refill)
(declare (type simple-stream stream) (declare (type simple-stream stream)
...@@ -226,6 +230,8 @@ ...@@ -226,6 +230,8 @@
(multiple-value-bind (hi lo) (multiple-value-bind (hi lo)
(lisp::surrogates code) (lisp::surrogates code)
(output hi (char-code hi) (sm control-in stream)) (output hi (char-code hi) (sm control-in stream))
;; What do we do if the low (trailing surrogate) wants
;; to be placed after the specified end of the string?
(when lo (when lo
(incf posn) (incf posn)
(incf count) (incf count)
...@@ -254,6 +260,42 @@ ...@@ -254,6 +260,42 @@
(incf (sm charpos stream))))))) (incf (sm charpos stream)))))))
character)) character))
(def-ef-macro %sc-write-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchars+)
`(lambda (string stream start end)
(declare (string string)
(type simple-stream stream))
(with-stream-class (simple-stream stream)
(do ((ef (sm external-format stream))
(len (length string))
(ctrl (sm control-out stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((>= posn end)
count)
(declare (type fixnum posn count))
(flet ((output (code)
(unless (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream (code-char code)))
(codepoint-to-octets ,ef
code
(sm oc-state stream)
(lambda (byte)
(when (>= (sm buffpos stream) (sm buffer-ptr stream))
(setf (sm buffpos stream) (flush-buffer stream t)))
(setf (bref (sm buffer stream) (sm buffpos stream)) byte)
(incf (sm buffpos stream)))))
(sc-set-dirty stream)
(when (sm charpos stream)
(incf (sm charpos stream)))))
(multiple-value-bind (code widep)
(lisp::codepoint string posn len)
(output code)
(when widep
(incf posn)
(incf count))))))))
(def-ef-macro %dc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+) (def-ef-macro %dc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+)
`(lambda (character stream) `(lambda (character stream)
(declare (type simple-stream stream)) (declare (type simple-stream stream))
...@@ -275,6 +317,40 @@ ...@@ -275,6 +317,40 @@
(when (sm charpos stream) (when (sm charpos stream)
(incf (sm charpos stream))))))) (incf (sm charpos stream)))))))
character)) character))
(def-ef-macro %dc-write-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchars+)
`(lambda (string stream start end)
(declare (string string)
(type simple-stream stream))
(with-stream-class (simple-stream stream)
(do ((ef (sm external-format stream))
(len (length string))
(ctrl (sm control-out stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((>= posn end)
count)
(declare (type fixnum posn count))
(flet ((output (code)
(unless (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream (code-char code)))
(codepoint-to-octets ,ef
code
(sm oc-state stream)
(lambda (byte)
(when (>= (sm buffpos stream) (sm max-out-pos stream))
(setf (sm outpos stream) (flush-buffer stream t)))
(setf (bref (sm out-buffer stream) (sm outpos stream)) byte)
(incf (sm outpos stream)))))
(when (sm charpos stream)
(incf (sm charpos stream)))))
(multiple-value-bind (code widep)
(lisp::codepoint string posn len)
(output code)
(when widep
(incf posn)
(incf count))))))))
;;;; Single-Channel-Simple-Stream strategy functions ;;;; Single-Channel-Simple-Stream strategy functions
...@@ -515,20 +591,8 @@ ...@@ -515,20 +591,8 @@
(declaim (ftype j-write-chars-fn (sc write-chars :ef))) (declaim (ftype j-write-chars-fn (sc write-chars :ef)))
(defun (sc write-chars :ef) (string stream start end) (defun (sc write-chars :ef) (string stream start end)
(with-stream-class (simple-stream stream) (with-stream-class (simple-stream stream)
(do ((ef (sm external-format stream)) (funcall (%sc-write-chars-fn (sm external-format stream))
(ctrl (sm control-out stream)) string stream start end)))
(posn start (1+ posn))
(count 0 (1+ count)))
((>= posn end)
count)
(declare (type fixnum posn count))
(let* ((char (char string posn))
(code (char-code char)))
(unless (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream char))
(funcall (%sc-write-char-fn ef)
char stream))))))
;;;; Dual-Channel-Simple-Stream strategy functions ;;;; Dual-Channel-Simple-Stream strategy functions
...@@ -544,19 +608,8 @@ ...@@ -544,19 +608,8 @@
(declaim (ftype j-write-chars-fn (dc write-chars :ef))) (declaim (ftype j-write-chars-fn (dc write-chars :ef)))
(defun (dc write-chars :ef) (string stream start end) (defun (dc write-chars :ef) (string stream start end)
(with-stream-class (dual-channel-simple-stream stream) (with-stream-class (dual-channel-simple-stream stream)
(do ((ctrl (sm control-out stream)) (funcall (%dc-write-chars-fn (sm external-format stream))
(posn start (1+ posn)) string stream start end)))
(count 0 (1+ count)))
((>= posn end)
count)
(declare (type fixnum posn count))
(let* ((char (char string posn))
(code (char-code char)))
(unless (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream char))
(funcall (%dc-write-char-fn (sm external-format stream))
char stream))))))
;;;; String-Simple-Stream strategy functions ;;;; String-Simple-Stream strategy functions
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment