/[cmucl]/src/hemlock/files.lisp
ViewVC logotype

Contents of /src/hemlock/files.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon Jun 29 21:10:48 2009 UTC (4 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.4: +14 -17 lines
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.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/files.lisp,v 1.5 2009/06/29 21:10:48 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Hemlock File manipulation functions.
13 ;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan.
14 ;;;
15
16 (in-package "HEMLOCK-INTERNALS")
17
18 (export '(read-file write-file))
19
20
21
22 ;;;; Utility functions.
23
24 (defun find-char-from-sap (sap start end char)
25 (declare (type system-area-pointer sap)
26 (type (integer 0 (#.most-positive-fixnum)) start end)
27 (type base-char char))
28 (do ((index start (1+ index))
29 (code (char-code char)))
30 ((>= index end) nil)
31 (declare (type (integer 0 #.most-positive-fixnum) index)
32 (type (unsigned-byte 8) code))
33 (when (= (sap-ref-8 sap index) code)
34 (return index))))
35
36
37 ;;; Read-File:
38
39 (defun read-file (pathname mark)
40 "Inserts the contents of the file named by Pathname at the Mark."
41 (with-mark ((mark mark :left-inserting))
42 (let* ((tn (truename pathname))
43 (name (namestring tn))
44 (sap nil)
45 (size 0))
46 (declare (fixnum size)
47 (type (or null system-area-pointer) sap))
48 (multiple-value-bind (fd err) (unix:unix-open name unix:o_rdonly 0)
49 (when fd
50 (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
51 (unix:unix-fstat fd)
52 (declare (ignore ino mode nlnk uid gid rdev))
53 (cond ((null res)
54 (setq err dev))
55 (t
56 (setf sap (system:allocate-system-memory len))
57 (setf size len)
58 (multiple-value-bind
59 (bytes err3)
60 (unix:unix-read fd sap len)
61 (if (or (null bytes) (not (= len bytes)))
62 (setq err err3)
63 (setq err nil))))))
64 (unix:unix-close fd))
65 (when err
66 (error "Reading file ~A, unix error ~A."
67 name (unix:get-unix-error-msg err)))
68 (when (zerop size)
69 (return-from read-file nil))
70 (let* ((first-line (mark-line mark))
71 (buffer (line-%buffer first-line))
72 (index (find-char-from-sap sap 0 size #\newline)))
73 (declare (type (or null (integer 0 (#.most-positive-fixnum))) index))
74 (modifying-buffer buffer)
75 (let* ((len (or index size))
76 (chars (make-string len)))
77 (%sp-byte-blt sap 0 chars 0 len)
78 (insert-string mark chars))
79 (when index
80 (insert-character mark #\newline)
81 (do* ((old-index (1+ index) (1+ index))
82 (index (find-char-from-sap sap old-index size #\newline)
83 (find-char-from-sap sap old-index size #\newline))
84 (number (+ (line-number first-line) line-increment)
85 (+ number line-increment))
86 (previous first-line))
87 ((not index)
88 (let* ((length (- size old-index))
89 (chars (make-string length))
90 (line (mark-line mark)))
91 (declare (fixnum length))
92 (%sp-byte-blt sap old-index chars 0 length)
93 (insert-string mark chars)
94 (setf (line-next previous) line)
95 (setf (line-previous line) previous)
96 (do ((line line (line-next line))
97 (number number (+ number line-increment)))
98 ((null line))
99 (declare (fixnum number))
100 (setf (line-number line) number))))
101 (declare (fixnum number old-index))
102 (let ((line (make-line
103 :previous previous
104 :%buffer buffer
105 :number number
106 :chars (system:sap+ sap old-index)
107 :buffered-p
108 (the fixnum (- (the fixnum index) old-index)))))
109 (setf (line-next previous) line)
110 (setq previous line))) nil))))))
111
112
113 ;;; Hackish stuff for disgusting speed:
114
115 (defun read-buffered-line (line)
116 (let* ((len (line-buffered-p line))
117 (chars (make-string len)))
118 (%sp-byte-blt (line-%chars line) 0 chars 0 len)
119 (setf (line-buffered-p line) nil)
120 (setf (line-chars line) chars)))
121
122
123
124 ;;; Write-File:
125
126 (defun write-file (region pathname &key append
127 (keep-backup (value ed::keep-backup-files))
128 access)
129 "Writes the characters in region to the file named by pathname. This writes
130 region using a stream opened with :if-exists :rename-and-delete, unless
131 either append or keep-backup is supplied. If append is supplied, this
132 writes the file opened with :if-exists :append. If keep-backup is supplied,
133 this writes the file opened with :if-exists :rename. This signals an error
134 if both append and keep-backup are supplied. Access is an implementation
135 dependent value that is suitable for setting pathname's access or protection
136 bits."
137 (let ((if-exists-action (cond ((and keep-backup append)
138 (error "Cannot supply non-nil values for ~
139 both keep-backup and append."))
140 (keep-backup :rename)
141 (append :append)
142 (t :rename-and-delete))))
143 (with-open-file (file pathname :direction :output
144 :element-type 'base-char
145 :if-exists if-exists-action)
146 (close-line)
147 (fast-write-file region file))
148 (when access
149 (multiple-value-bind
150 (winp code)
151 ;; Must do a TRUENAME in case the file has never been written.
152 ;; It may have Common Lisp syntax that Unix can't handle.
153 ;; If this is ever moved to the beginning of this function to use
154 ;; Unix CREAT to create the file protected initially, they TRUENAME
155 ;; will signal an error, and LISP::PREDICT-NAME will have to be used.
156 (unix:unix-chmod (namestring (truename pathname)) access)
157 (unless winp
158 (error "Could not set access code: ~S"
159 (unix:get-unix-error-msg code)))))))
160
161 (defun fast-write-file (region file)
162 (let* ((start (region-start region))
163 (start-line (mark-line start))
164 (start-charpos (mark-charpos start))
165 (end (region-end region))
166 (end-line (mark-line end))
167 (end-charpos (mark-charpos end)))
168 (if (eq start-line end-line)
169 (write-string (line-chars start-line) file
170 :start start-charpos :end end-charpos)
171 (let* ((first-length (- (line-length start-line) start-charpos))
172 (length (+ first-length end-charpos 1)))
173 (do ((line (line-next start-line) (line-next line)))
174 ((eq line end-line))
175 (incf length (1+ (line-length line))))
176 (let ((sap (system:allocate-system-memory length)))
177 (unwind-protect
178 (macrolet ((chars (line)
179 `(if (line-buffered-p ,line)
180 (line-%chars ,line)
181 (line-chars ,line))))
182 (system:%sp-byte-blt (chars start-line) start-charpos
183 sap 0 first-length)
184 (setf (system:sap-ref-8 sap first-length)
185 (char-code #\newline))
186 (let ((offset (1+ first-length)))
187 (do ((line (line-next start-line)
188 (line-next line)))
189 ((eq line end-line))
190 (let ((end (+ offset (line-length line))))
191 (system:%sp-byte-blt (chars line) 0
192 sap offset end)
193 (setf (system:sap-ref-8 sap end)
194 (char-code #\newline))
195 (setf offset (1+ end))))
196 (unless (zerop end-charpos)
197 (system:%sp-byte-blt (chars end-line) 0
198 sap offset
199 (+ offset end-charpos))))
200 (multiple-value-bind
201 (okay errno)
202 (unix:unix-write (system:fd-stream-fd file)
203 sap 0 length)
204 (unless okay
205 (error "Could not write ~S: ~A"
206 file
207 (unix:get-unix-error-msg errno)))))
208 (system:deallocate-system-memory sap length)))))))

  ViewVC Help
Powered by ViewVC 1.1.5