source: trunk/abcl/src/org/armedbear/lisp/open.lisp

Last change on this file was 15447, checked in by Mark Evenson, 4 months ago

SYS:MAKE-FILE-STREAM doesn't need a namestring

Manipulation of pathnames should happen (mostly) with the objects
themselves rather than their namestring.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.5 KB
Line 
1;;; open.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: open.lisp 15447 2020-10-29 16:54:43Z 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))))))
Note: See TracBrowser for help on using the repository browser.