1 | ;;; open.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: open.lisp 15569 2022-03-19 12:50:18Z mevenson $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | ;;; |
---|
20 | ;;; As a special exception, the copyright holders of this library give you |
---|
21 | ;;; permission to link this library with independent modules to produce an |
---|
22 | ;;; executable, regardless of the license terms of these independent |
---|
23 | ;;; modules, and to copy and distribute the resulting executable under |
---|
24 | ;;; terms of your choice, provided that you also meet, for each linked |
---|
25 | ;;; independent module, the terms and conditions of the license of that |
---|
26 | ;;; module. An independent module is a module which is not derived from |
---|
27 | ;;; or based on this library. If you modify this library, you may extend |
---|
28 | ;;; this exception to your version of the library, but you are not |
---|
29 | ;;; obligated to do so. If you do not wish to do so, delete this |
---|
30 | ;;; exception statement from your version. |
---|
31 | |
---|
32 | ;;; Adapted from SBCL. |
---|
33 | |
---|
34 | (in-package #:system) |
---|
35 | |
---|
36 | (defun upgraded-element-type-bits (bits) |
---|
37 | (if (zerop (mod bits 8)) |
---|
38 | bits |
---|
39 | (+ bits (- 8 (mod bits 8))))) |
---|
40 | |
---|
41 | (defun upgraded-element-type (element-type) |
---|
42 | (setf element-type (normalize-type element-type)) |
---|
43 | (let ((ok nil)) |
---|
44 | (if (atom element-type) |
---|
45 | (case element-type |
---|
46 | ((character base-char) |
---|
47 | (setf ok t)) |
---|
48 | ((unsigned-byte signed-byte) |
---|
49 | (setf element-type (list element-type 8) |
---|
50 | ok t)) |
---|
51 | (bit |
---|
52 | (setf element-type (list 'unsigned-byte (upgraded-element-type-bits 1)) |
---|
53 | ok t)) |
---|
54 | (integer |
---|
55 | (setf element-type '(signed-byte 8) |
---|
56 | ok t))) |
---|
57 | (cond ((eq (%car element-type) 'or) |
---|
58 | (let ((types (mapcar #'upgraded-element-type (%cdr element-type))) |
---|
59 | (result '(unsigned-byte 8))) |
---|
60 | (dolist (type types) |
---|
61 | (when (eq (car type) 'signed-byte) |
---|
62 | (setf (car result) 'signed-byte)) |
---|
63 | (setf (cadr result) (max (cadr result) (cadr type)))) |
---|
64 | (setf element-type result |
---|
65 | ok t))) |
---|
66 | ((and (= (length element-type) 2) |
---|
67 | (memq (%car element-type) '(unsigned-byte signed-byte))) |
---|
68 | (let ((type (car element-type)) |
---|
69 | (width (cadr element-type))) |
---|
70 | (setf element-type (list type |
---|
71 | (upgraded-element-type-bits width)) |
---|
72 | ok t))) |
---|
73 | ((eq (car element-type) 'integer) |
---|
74 | (case (length element-type) |
---|
75 | (2 |
---|
76 | (setf element-type '(signed-byte 8) |
---|
77 | ok t)) |
---|
78 | (3 |
---|
79 | (let ((low (cadr element-type)) |
---|
80 | (high (caddr element-type))) |
---|
81 | (when (consp low) |
---|
82 | (setf low (1+ (%car low)))) |
---|
83 | (when (consp high) |
---|
84 | (setf high (1- (%car high)))) |
---|
85 | (setf element-type |
---|
86 | (cond ((eq high '*) |
---|
87 | (if (minusp low) '(signed-byte 8) '(unsigned-byte 8))) |
---|
88 | ((minusp low) |
---|
89 | (list 'signed-byte |
---|
90 | (upgraded-element-type-bits (max (1+ (integer-length low)) |
---|
91 | (integer-length high))))) |
---|
92 | (t |
---|
93 | (list 'unsigned-byte |
---|
94 | (upgraded-element-type-bits (integer-length high))))) |
---|
95 | ok t))))))) |
---|
96 | (if ok |
---|
97 | element-type |
---|
98 | (error 'file-error |
---|
99 | :format-control "Unsupported element type ~S." |
---|
100 | :format-arguments (list element-type))))) |
---|
101 | |
---|
102 | (defun open (filename |
---|
103 | &key |
---|
104 | (direction :input) |
---|
105 | (element-type 'character) |
---|
106 | (if-exists nil if-exists-given) |
---|
107 | (if-does-not-exist nil if-does-not-exist-given) |
---|
108 | (external-format :default)) |
---|
109 | ; (declare (ignore external-format)) ; FIXME |
---|
110 | (setf element-type (case element-type |
---|
111 | ((character base-char) |
---|
112 | 'character) |
---|
113 | (:default |
---|
114 | '(unsigned-byte 8)) |
---|
115 | (t |
---|
116 | (upgraded-element-type element-type)))) |
---|
117 | (let* ((p (merge-pathnames filename)) |
---|
118 | (pathname (if (typep p 'logical-pathname) |
---|
119 | (translate-logical-pathname p) |
---|
120 | p))) |
---|
121 | (when (wild-pathname-p pathname) |
---|
122 | (error 'file-error |
---|
123 | :pathname pathname |
---|
124 | :format-control "Cannot OPEN a wild pathname.")) |
---|
125 | (when (memq direction '(:output :io)) |
---|
126 | (unless if-exists-given |
---|
127 | (setf if-exists |
---|
128 | (if (eq (pathname-version pathname) :newest) |
---|
129 | :new-version |
---|
130 | :error)))) |
---|
131 | (unless if-does-not-exist-given |
---|
132 | (setf if-does-not-exist |
---|
133 | (cond ((eq direction :input) :error) |
---|
134 | ((and (memq direction '(:output :io)) |
---|
135 | (memq if-exists '(:overwrite :append))) |
---|
136 | :error) |
---|
137 | ((eq direction :probe) |
---|
138 | nil) |
---|
139 | (t |
---|
140 | :create)))) |
---|
141 | (case direction |
---|
142 | (:input |
---|
143 | (case if-does-not-exist |
---|
144 | (:error |
---|
145 | (unless (probe-file pathname) |
---|
146 | (error 'file-error |
---|
147 | :pathname pathname |
---|
148 | :format-control "The file ~S does not exist." |
---|
149 | :format-arguments (list pathname)))) |
---|
150 | (:create |
---|
151 | ;; CREATE-NEW-FILE "atomically creates a new, empty file named by |
---|
152 | ;; this abstract pathname if and only if a file with this name does |
---|
153 | ;; not yet exist." See java.io.File.createNewFile(). |
---|
154 | (create-new-file (namestring pathname)))) |
---|
155 | (make-file-stream pathname element-type :input nil external-format)) |
---|
156 | (:probe |
---|
157 | (case if-does-not-exist |
---|
158 | (:error |
---|
159 | (unless (probe-file pathname) |
---|
160 | (error 'file-error |
---|
161 | :pathname pathname |
---|
162 | :format-control "The file ~S does not exist." |
---|
163 | :format-arguments (list pathname)))) |
---|
164 | (:create |
---|
165 | ;; CREATE-NEW-FILE "atomically creates a new, empty file named by |
---|
166 | ;; this abstract pathname if and only if a file with this name does |
---|
167 | ;; not yet exist." See java.io.File.createNewFile(). |
---|
168 | (create-new-file (namestring pathname)))) |
---|
169 | (let ((stream (make-file-stream pathname element-type |
---|
170 | :input nil external-format))) |
---|
171 | (when stream |
---|
172 | (close stream)) |
---|
173 | stream)) |
---|
174 | ((:output :io) |
---|
175 | (case if-does-not-exist |
---|
176 | (:error |
---|
177 | (unless (probe-file pathname) |
---|
178 | (error 'file-error |
---|
179 | :pathname pathname |
---|
180 | :format-control "The file ~S does not exist." |
---|
181 | :format-arguments (list pathname)))) |
---|
182 | ((nil) |
---|
183 | (unless (probe-file pathname) |
---|
184 | (return-from open nil)))) |
---|
185 | (case if-exists |
---|
186 | (:error |
---|
187 | (when (probe-file pathname) |
---|
188 | (error 'file-error |
---|
189 | :pathname pathname |
---|
190 | :format-control "The file ~S already exists." |
---|
191 | :format-arguments (list pathname)))) |
---|
192 | ((nil) |
---|
193 | (when (probe-file pathname) |
---|
194 | (return-from open nil))) |
---|
195 | ((:rename :rename-and-delete) |
---|
196 | (when (probe-file pathname) |
---|
197 | ;; Make sure the original file is not a directory. |
---|
198 | (when (probe-directory pathname) |
---|
199 | (error 'file-error |
---|
200 | :pathname pathname |
---|
201 | :format-control "The file ~S is a directory." |
---|
202 | :format-arguments (list pathname))) |
---|
203 | (let ((backup-name (concatenate 'string (namestring pathname) ".bak"))) |
---|
204 | (when (probe-file backup-name) |
---|
205 | (when (probe-directory backup-name) |
---|
206 | (error 'file-error |
---|
207 | :pathname pathname |
---|
208 | :format-control "Unable to rename ~S to ~S." |
---|
209 | :format-arguments (list pathname backup-name))) |
---|
210 | (delete-file backup-name)) |
---|
211 | (rename-file pathname backup-name)))) |
---|
212 | ((:new-version :supersede :overwrite :append)) ; OK to proceed. |
---|
213 | (t |
---|
214 | (error 'simple-error |
---|
215 | :format-control "Option not supported: ~S." |
---|
216 | :format-arguments (list if-exists)))) |
---|
217 | (let ((stream (make-file-stream pathname element-type |
---|
218 | direction if-exists external-format))) |
---|
219 | (unless stream |
---|
220 | (error 'file-error |
---|
221 | :pathname pathname |
---|
222 | :format-control "Unable to open ~S." |
---|
223 | :format-arguments (list pathname))) |
---|
224 | stream)) |
---|
225 | (t |
---|
226 | (error 'simple-error |
---|
227 | :format-control ":DIRECTION ~S not supported." |
---|
228 | :format-arguments (list direction)))))) |
---|