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

Make reading and writing from files work with unicode. (Of course,

only 8-bit characters are supported.)

hacks.lisp:
o Update %SP-BYTE-BLT to be able to handle saps and strings for either
  the source or destination.

files.lisp:
o Use %SP-BYTE-BLT instead of %PRIMITIVE BYTE-BLT.
parent 054dfb41
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/files.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/files.lisp,v 1.5 2009/06/29 21:10:48 rtoy Rel $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -48,7 +48,7 @@ ...@@ -48,7 +48,7 @@
(multiple-value-bind (fd err) (unix:unix-open name unix:o_rdonly 0) (multiple-value-bind (fd err) (unix:unix-open name unix:o_rdonly 0)
(when fd (when fd
(multiple-value-bind (res dev ino mode nlnk uid gid rdev len) (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
(unix:unix-fstat fd) (unix:unix-fstat fd)
(declare (ignore ino mode nlnk uid gid rdev)) (declare (ignore ino mode nlnk uid gid rdev))
(cond ((null res) (cond ((null res)
(setq err dev)) (setq err dev))
...@@ -56,7 +56,7 @@ ...@@ -56,7 +56,7 @@
(setf sap (system:allocate-system-memory len)) (setf sap (system:allocate-system-memory len))
(setf size len) (setf size len)
(multiple-value-bind (multiple-value-bind
(bytes err3) (bytes err3)
(unix:unix-read fd sap len) (unix:unix-read fd sap len)
(if (or (null bytes) (not (= len bytes))) (if (or (null bytes) (not (= len bytes)))
(setq err err3) (setq err err3)
...@@ -74,7 +74,7 @@ ...@@ -74,7 +74,7 @@
(modifying-buffer buffer) (modifying-buffer buffer)
(let* ((len (or index size)) (let* ((len (or index size))
(chars (make-string len))) (chars (make-string len)))
(%primitive byte-blt sap 0 chars 0 len) (%sp-byte-blt sap 0 chars 0 len)
(insert-string mark chars)) (insert-string mark chars))
(when index (when index
(insert-character mark #\newline) (insert-character mark #\newline)
...@@ -89,7 +89,7 @@ ...@@ -89,7 +89,7 @@
(chars (make-string length)) (chars (make-string length))
(line (mark-line mark))) (line (mark-line mark)))
(declare (fixnum length)) (declare (fixnum length))
(%primitive byte-blt sap old-index chars 0 length) (%sp-byte-blt sap old-index chars 0 length)
(insert-string mark chars) (insert-string mark chars)
(setf (line-next previous) line) (setf (line-next previous) line)
(setf (line-previous line) previous) (setf (line-previous line) previous)
...@@ -115,7 +115,7 @@ ...@@ -115,7 +115,7 @@
(defun read-buffered-line (line) (defun read-buffered-line (line)
(let* ((len (line-buffered-p line)) (let* ((len (line-buffered-p line))
(chars (make-string len))) (chars (make-string len)))
(%primitive byte-blt (line-%chars line) 0 chars 0 len) (%sp-byte-blt (line-%chars line) 0 chars 0 len)
(setf (line-buffered-p line) nil) (setf (line-buffered-p line) nil)
(setf (line-chars line) chars))) (setf (line-chars line) chars)))
...@@ -178,10 +178,9 @@ ...@@ -178,10 +178,9 @@
(macrolet ((chars (line) (macrolet ((chars (line)
`(if (line-buffered-p ,line) `(if (line-buffered-p ,line)
(line-%chars ,line) (line-%chars ,line)
(line-chars ,line)))) (line-chars ,line))))
(system:%primitive byte-blt (system:%sp-byte-blt (chars start-line) start-charpos
(chars start-line) start-charpos sap 0 first-length)
sap 0 first-length)
(setf (system:sap-ref-8 sap first-length) (setf (system:sap-ref-8 sap first-length)
(char-code #\newline)) (char-code #\newline))
(let ((offset (1+ first-length))) (let ((offset (1+ first-length)))
...@@ -189,17 +188,15 @@ ...@@ -189,17 +188,15 @@
(line-next line))) (line-next line)))
((eq line end-line)) ((eq line end-line))
(let ((end (+ offset (line-length line)))) (let ((end (+ offset (line-length line))))
(system:%primitive byte-blt (system:%sp-byte-blt (chars line) 0
(chars line) 0 sap offset end)
sap offset end)
(setf (system:sap-ref-8 sap end) (setf (system:sap-ref-8 sap end)
(char-code #\newline)) (char-code #\newline))
(setf offset (1+ end)))) (setf offset (1+ end))))
(unless (zerop end-charpos) (unless (zerop end-charpos)
(system:%primitive byte-blt (system:%sp-byte-blt (chars end-line) 0
(chars end-line) 0 sap offset
sap offset (+ offset end-charpos))))
(+ offset end-charpos))))
(multiple-value-bind (multiple-value-bind
(okay errno) (okay errno)
(unix:unix-write (system:fd-stream-fd file) (unix:unix-write (system:fd-stream-fd file)
......
...@@ -4,10 +4,32 @@ ...@@ -4,10 +4,32 @@
#-unicode #-unicode
(%primitive byte-blt src start dest dstart end) (%primitive byte-blt src start dest dstart end)
#+unicode #+unicode
(loop for di of-type fixnum from dstart below end (etypecase src
for si of-type fixnum from start (system:system-area-pointer
do (etypecase dest
(setf (aref dest di) (aref src si)))) (system:system-area-pointer
(loop for di of-type fixnum from dstart below end
for si of-type fixnum from start
do
(setf (sys:sap-ref-8 dest di) (sys:sap-ref-8 src si))))
(string
(loop for di of-type fixnum from dstart below end
for si of-type fixnum from start
do
(setf (aref dest di) (code-char (sys:sap-ref-8 src si)))))))
(string
(etypecase dest
(system:system-area-pointer
(loop for di of-type fixnum from dstart below end
for si of-type fixnum from start
do
(setf (sys:sap-ref-8 dest di) (logand #xff (char-code (aref src si))))))
(string
(loop for di of-type fixnum from dstart below end
for si of-type fixnum from start
do
(setf (aref dest di) (aref src si))))))))
(defun lisp::sap-to-fixnum (x) (sap-int x)) (defun lisp::sap-to-fixnum (x) (sap-int x))
(defun lisp::fixnum-to-sap (x) (int-sap x)) (defun lisp::fixnum-to-sap (x) (int-sap x))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment