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

Last change on this file since 11391 was 11391, checked in by vvoutilainen, 12 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.1 KB
Line 
1;;; open.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: open.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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))
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 :input nil)))
161         (when stream
162           (close stream))
163         stream))
164      ((:output :io)
165       (case if-does-not-exist
166         (:error
167          (unless (probe-file pathname)
168            (error 'file-error
169                   :pathname pathname
170                   :format-control "The file ~S does not exist."
171                   :format-arguments (list namestring))))
172         ((nil)
173          (unless (probe-file pathname)
174            (return-from open nil))))
175       (case if-exists
176         (:error
177          (when (probe-file pathname)
178            (error 'file-error
179                   :pathname pathname
180                   :format-control "The file ~S already exists."
181                   :format-arguments (list namestring))))
182         ((nil)
183          (when (probe-file pathname)
184            (return-from open nil)))
185         ((:rename :rename-and-delete)
186          (when (probe-file pathname)
187            ;; Make sure the original file is not a directory.
188            (when (probe-directory pathname)
189              (error 'file-error
190                     :pathname pathname
191                     :format-control "The file ~S is a directory."
192                     :format-arguments (list namestring)))
193            (let ((backup-name (concatenate 'string namestring ".bak")))
194              (when (probe-file backup-name)
195                (when (probe-directory backup-name)
196                  (error 'file-error
197                         :pathname pathname
198                         :format-control "Unable to rename ~S."
199                         :format-arguments (list namestring)))
200                (delete-file backup-name))
201              (rename-file pathname backup-name))))
202         ((:new-version :supersede :overwrite :append)) ; OK to proceed.
203         (t
204          (error 'simple-error
205                 :format-control "Option not supported: ~S."
206                 :format-arguments (list if-exists))))
207       (let ((stream (make-file-stream pathname namestring element-type direction if-exists)))
208         (unless stream
209           (error 'file-error
210                  :pathname pathname
211                  :format-control "Unable to open ~S."
212                  :format-arguments (list namestring)))
213         stream))
214      (t
215       (error 'simple-error
216              :format-control ":DIRECTION ~S not supported."
217              :format-arguments (list direction))))))
Note: See TracBrowser for help on using the repository browser.