source: trunk/j/src/org/armedbear/lisp/open.lisp @ 11434

Last change on this file since 11434 was 11434, checked in by ehuelsmann, 13 years ago

Merge open-external-format branch back to trunk.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.2 KB
Line 
1;;; open.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: open.lisp 11434 2008-12-07 23:24:31Z ehuelsmann $
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* ((pathname (merge-pathnames filename))
118         (namestring (namestring (if (typep pathname 'logical-pathname)
119                                     (translate-logical-pathname pathname)
120                                     pathname))))
121    (when (memq direction '(:output :io))
122      (unless if-exists-given
123        (setf if-exists
124              (if (eq (pathname-version pathname) :newest)
125                  :new-version
126                  :error))))
127    (unless if-does-not-exist-given
128      (setf if-does-not-exist
129            (cond ((eq direction :input) :error)
130                  ((and (memq direction '(:output :io))
131                        (memq if-exists '(:overwrite :append)))
132                   :error)
133                  ((eq direction :probe)
134                   nil)
135                  (t
136                   :create))))
137    (case direction
138      (:input
139       (case if-does-not-exist
140         (:error
141          (unless (probe-file pathname)
142            (error 'file-error
143                   :pathname pathname
144                   :format-control "The file ~S does not exist."
145                   :format-arguments (list namestring)))))
146       (make-file-stream pathname namestring element-type :input nil external-format))
147      (:probe
148       (case if-does-not-exist
149         (:error
150          (unless (probe-file pathname)
151            (error 'file-error
152                   :pathname pathname
153                   :format-control "The file ~S does not exist."
154                   :format-arguments (list namestring))))
155         (:create
156          ;; CREATE-NEW-FILE "atomically creates a new, empty file named by
157          ;; this abstract pathname if and only if a file with this name does
158          ;; not yet exist." See java.io.File.createNewFile().
159          (create-new-file namestring)))
160       (let ((stream (make-file-stream pathname namestring element-type
161                                       :input nil external-format)))
162         (when stream
163           (close stream))
164         stream))
165      ((:output :io)
166       (case if-does-not-exist
167         (:error
168          (unless (probe-file pathname)
169            (error 'file-error
170                   :pathname pathname
171                   :format-control "The file ~S does not exist."
172                   :format-arguments (list namestring))))
173         ((nil)
174          (unless (probe-file pathname)
175            (return-from open nil))))
176       (case if-exists
177         (:error
178          (when (probe-file pathname)
179            (error 'file-error
180                   :pathname pathname
181                   :format-control "The file ~S already exists."
182                   :format-arguments (list namestring))))
183         ((nil)
184          (when (probe-file pathname)
185            (return-from open nil)))
186         ((:rename :rename-and-delete)
187          (when (probe-file pathname)
188            ;; Make sure the original file is not a directory.
189            (when (probe-directory pathname)
190              (error 'file-error
191                     :pathname pathname
192                     :format-control "The file ~S is a directory."
193                     :format-arguments (list namestring)))
194            (let ((backup-name (concatenate 'string namestring ".bak")))
195              (when (probe-file backup-name)
196                (when (probe-directory backup-name)
197                  (error 'file-error
198                         :pathname pathname
199                         :format-control "Unable to rename ~S."
200                         :format-arguments (list namestring)))
201                (delete-file backup-name))
202              (rename-file pathname backup-name))))
203         ((:new-version :supersede :overwrite :append)) ; OK to proceed.
204         (t
205          (error 'simple-error
206                 :format-control "Option not supported: ~S."
207                 :format-arguments (list if-exists))))
208       (let ((stream (make-file-stream pathname namestring element-type
209                                       direction if-exists external-format)))
210         (unless stream
211           (error 'file-error
212                  :pathname pathname
213                  :format-control "Unable to open ~S."
214                  :format-arguments (list namestring)))
215         stream))
216      (t
217       (error 'simple-error
218              :format-control ":DIRECTION ~S not supported."
219              :format-arguments (list direction))))))
Note: See TracBrowser for help on using the repository browser.